diff --git a/.ffmt.toml b/.ffmt.toml new file mode 100644 index 0000000000..ffeaae969d --- /dev/null +++ b/.ffmt.toml @@ -0,0 +1,18 @@ +# 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 +slice-colon = false 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/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. diff --git a/src/common/include/1dHardcodedIC.fpp b/src/common/include/1dHardcodedIC.fpp index 4359528a3f..562005ac32 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)) @@ -13,24 +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) - ! This hardcoded case can be used to start a simulation with initial conditions given from a known 1D profile (e.g. Cantera, SDtoolbox) + 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) - ! 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)" + 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) - ! 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)" + 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 @@ -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..b2752228f0 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,21 +17,17 @@ #:enddef #:def Hardcoded2D() - - select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case - - case (200) + select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case + 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 q_prim_vf(advxe)%sf(i, j, 0) = 1._wp - eps - ! Denssities 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 @@ -53,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 @@ -76,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 @@ -107,11 +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 @@ -122,30 +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 + 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 ei = 5.0_wp @@ -160,25 +150,20 @@ 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) - ! 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) + 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) 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)) 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 - 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) @@ -189,29 +174,21 @@ end if ! 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. + 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 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) @@ -223,11 +200,9 @@ 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 - ! C. Ciuca, P. Fernandez, A. Christophe, N.C. Nguyen, J. Peraire + 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 ! 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)) @@ -238,13 +213,12 @@ 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) - + 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. + ! 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,7 +226,6 @@ ! 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 r0 = 1._wp/sqrt(8._wp) r2 = x_cc(i)**2 + y_cc(j)**2 @@ -261,12 +234,11 @@ 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 α = atan(2) + ! rotate by \alpha = atan(2) alpha = atan(2._wp) cosA = cos(alpha) sinA = sin(alpha) @@ -274,69 +246,68 @@ 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) + 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) - ! This is patch is hard-coded for test suite optimization used in the - ! 2D_isentropicvortex case: - ! This analytic patch uses geometry 2 + 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 - 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 + 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 - 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 + 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 - 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..ec63047d72 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -3,19 +3,17 @@ 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 - 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 + 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 @@ -44,7 +42,7 @@ end if if (l == 0) then read (value, *) y_th_arr(q) ! Convert string to numeric value - elseif (l == 1) then + else if (l == 1) then read (value, *) z_th_arr(q) else read (value, *) r_th_arr(q) @@ -64,13 +62,11 @@ end do end do end if - #:enddef #: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 @@ -101,8 +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) @@ -114,8 +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 @@ -145,9 +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) @@ -173,25 +165,21 @@ 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) - ! This is patch is hard-coded for test suite optimization used in the - ! 3D_TaylorGreenVortex case: - ! This analytic patch used geometry 9 + 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 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..07acc54a5e 100644 --- a/src/common/include/ExtrusionHardcodedIC.fpp +++ b/src/common/include/ExtrusionHardcodedIC.fpp @@ -1,71 +1,70 @@ -!> @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: +!> 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 - 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) + 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) #: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 @@ -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,10 +98,8 @@ ! 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 ! Find yRows by counting rows with same x read (unit2, *, iostat=ios2) x0, y0, dummy_z @@ -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..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,13 +191,14 @@ $: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 #: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 @@ -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() @@ -229,7 +232,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..61c13886c5 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -12,20 +12,15 @@ #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. NVIDIA unified memory page placement hint #: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. -! https://docs.nvidia.com/hpc-sdk/compilers/cuda-fortran-prog-guide/index.html#fortran-host-modules + ! 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 #else @@ -35,24 +30,23 @@ 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 - !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 @@ -61,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) @@ -70,7 +65,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) @@ -79,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) @@ -86,6 +83,7 @@ deallocate (${allocated_variables}$) #:enddef DEALLOCATE +! Cray-specific GPU pointer setup for vector fields #:def ACC_SETUP_VFs(*args) #ifdef _CRAYFTN block @@ -109,10 +107,10 @@ #endif #:enddef +! Cray-specific GPU pointer setup for scalar fields #:def ACC_SETUP_SFs(*args) #ifdef _CRAYFTN block - @:LOG({'@:ACC_SETUP_SFs(${', '.join(args)}$)'}) #:for arg in args @@ -125,10 +123,10 @@ #endif #:enddef +! Cray-specific GPU pointer setup for acoustic source spatials #: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..7620e7607f 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 @@ -242,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 @@ -253,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() @@ -271,7 +272,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..b1382ec49a 100644 --- a/src/common/include/parallel_macros.fpp +++ b/src/common/include/parallel_macros.fpp @@ -2,12 +2,15 @@ #: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) - #: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 @@ -16,27 +19,30 @@ #else $:code #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, & & 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 #elif defined(MFC_OpenMP) $:omp_directive #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() @@ -45,14 +51,16 @@ #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) +! 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) #: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 @@ -102,8 +110,11 @@ #: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) +! 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, & + & present=present, deviceptr=deviceptr, link=link, extraAccArgs=None) #:assert copyout is None #:assert present is None #:assert deviceptr is None @@ -117,9 +128,13 @@ #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) +! 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, & + & 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 @@ -128,9 +143,15 @@ #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) +! 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, & + & 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 @@ -141,8 +162,8 @@ #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 #:set use_device = use_device_addr + use_device_ptr @@ -158,7 +179,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 @@ -169,9 +191,12 @@ #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) - #: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 @@ -180,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) @@ -191,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) @@ -202,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' @@ -212,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) @@ -223,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) @@ -234,34 +264,37 @@ #endif #:enddef +! Import GPU library module (openacc or omp_lib) #:def USE_GPU_MODULE() - #if defined(MFC_OpenACC) use openacc #elif defined(MFC_OpenMP) use omp_lib #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 2a33ecfc60..918b0daea5 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -8,40 +8,28 @@ 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 - use m_compile_specific implicit none - type(scalar_field), dimension(:, :), allocatable :: bc_buffers + type(scalar_field), dimension(:,:), allocatable :: bc_buffers $: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, & - 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 @@ -51,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 @@ -78,27 +66,24 @@ 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. + !> 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 + 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 - integer :: k, l + ! BC type codes defined in m_constants.fpp; non-negative values are MPI boundaries - ! 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 +101,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,11 +112,11 @@ 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))) - 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) @@ -146,8 +130,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 +143,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 +166,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 +178,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 +196,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 +210,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 +231,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 +242,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 +260,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 @@ -292,65 +268,57 @@ contains $:END_GPU_PARALLEL_LOOP() 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. + !> 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) - 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 + $: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 - 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) + 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) + 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 - 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) + 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) + 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 - 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) + 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) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p) end do end do end if @@ -358,125 +326,107 @@ 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]') - 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 + $: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 + + 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 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) + 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 - 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) + 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,39 +434,33 @@ 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 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) + 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 +468,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 - 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) + 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,39 +504,33 @@ 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 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)) + 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,10 +538,8 @@ 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 @@ -619,22 +549,21 @@ 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]') - 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 + $: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 + + 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,19 +571,16 @@ 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 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) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) end do end do @@ -662,21 +588,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 - 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) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) end do end do @@ -684,19 +607,16 @@ 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 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) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, j - 1, l) end do end do @@ -704,21 +624,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 - 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)) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) end do end do @@ -726,19 +643,16 @@ 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 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) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, j - 1) end do end do @@ -746,10 +660,8 @@ 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 @@ -759,47 +671,39 @@ 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]') - 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 + $: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 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,10 +712,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 - ((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 @@ -819,90 +721,77 @@ 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) - 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 + $: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 - 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 - 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 - else !< bc_x%end + else !< bc_x%end 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 - 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 - 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 - else !< bc_y%end + else !< bc_y%end 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 - 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 - 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 - else !< bc_z%end + else !< bc_z%end 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 @@ -911,127 +800,102 @@ 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) - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l + $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', cray_inline=True) - integer :: j, i + 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 - 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 - 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 - else !< bc_x%end + else !< bc_x%end 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 - 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 - 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 - else !< bc_y%end + else !< bc_y%end 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 - 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 - 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 - else !< bc_z%end + else !< bc_z%end 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 @@ -1040,65 +904,58 @@ 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) - 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 + $: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 #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) + 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) + 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 + 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 + 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 + 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 + 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 @@ -1110,17 +967,17 @@ 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]') - 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 + $: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 - 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 @@ -1129,7 +986,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 @@ -1139,8 +996,8 @@ contains end do end do end if - elseif (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 @@ -1149,7 +1006,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 @@ -1159,8 +1016,8 @@ contains end do end do end if - elseif (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 @@ -1169,7 +1026,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 @@ -1183,19 +1040,19 @@ 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 - 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 + integer :: k, l - 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 - $: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 +1071,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 +1090,11 @@ 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 - $: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 +1113,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,17 +1128,16 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - #:endif 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 - $: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 +1156,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)) @@ -1317,54 +1172,54 @@ 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. + !> 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) - 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 + $: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 - 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 - elseif (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 - elseif (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) @@ -1375,18 +1230,17 @@ 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) - 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 + $: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 - 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 @@ -1396,7 +1250,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 @@ -1407,8 +1261,8 @@ contains end do end do end if - elseif (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 @@ -1418,7 +1272,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 @@ -1429,8 +1283,8 @@ contains end do end do end if - elseif (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 @@ -1440,7 +1294,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 @@ -1455,52 +1309,51 @@ 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) - 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 + $: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 - 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 - elseif (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 - elseif (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) @@ -1511,18 +1364,17 @@ 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 - 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) 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 +1394,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 +1419,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 +1447,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 +1473,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - #:endif #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 @@ -1634,7 +1481,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 +1506,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)) @@ -1681,25 +1528,26 @@ 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. + !> 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 + 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 +1558,24 @@ 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. + !> 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' @@ -1739,8 +1585,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,8 +1594,8 @@ 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 @@ -1759,28 +1605,26 @@ 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 - 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 - 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 +1639,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 @@ -1826,27 +1670,25 @@ 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 - - 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 - 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 +1698,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 @@ -1873,30 +1715,28 @@ 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 - - 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 - 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 +1747,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 @@ -1940,11 +1780,11 @@ 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 - integer :: i, j, k + integer :: i, j, k do k = 0, p do j = 0, n @@ -1956,7 +1796,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 +1807,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,33 +1817,31 @@ 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. + !> 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) - $: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 @@ -2013,17 +1849,16 @@ 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 !< Generic loop iterator + integer :: i #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 @@ -2035,15 +1870,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 +1896,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 @@ -2083,24 +1918,23 @@ 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 ! 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 +1952,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 @@ -2140,24 +1974,23 @@ 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 ! 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 +2008,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 @@ -2197,13 +2030,11 @@ 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 - !> @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 2280828a3a..df71030ec9 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -8,12 +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 @@ -22,8 +19,7 @@ module m_checker_common 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 @@ -36,23 +32,23 @@ 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 - integer(kind=8) :: min_cells + + 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) 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. + !> 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 @@ -64,7 +60,5 @@ contains 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..66f1e97923 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -9,21 +9,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 @@ -34,75 +31,66 @@ 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) + $: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) + ! 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 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 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), 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 - ! 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 + 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. + !> 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 + 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 @@ -119,18 +107,18 @@ 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 - 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 + type(int_bounds_info), dimension(1:3), intent(in) :: bounds + integer :: x, y, z + integer :: eqn + real(wp) :: T + real(wp) :: rho, omega_m - 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 +131,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,9 +149,7 @@ 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 @@ -172,14 +157,14 @@ 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 + 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 + type(int_bounds_info), intent(in) :: irx, iry, irz + integer, intent(in) :: idir - 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 +177,31 @@ 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 +261,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 +277,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 +290,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 +305,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 +327,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 +385,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 +400,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 diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index 6820ef3a9a..9d79811320 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -12,82 +12,86 @@ 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 #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. + !> Delete 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. + !> Recursively delete 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 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. + !> Retrieve 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. + !> 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 - character(LEN=*), intent(out) :: basename - integer :: iUnit - character(len=30) :: tmpfilepath + character(LEN=*), intent(in) :: dirpath + character(LEN=*), intent(out) :: basename + 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) diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index ece614b089..8e01059691 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -7,96 +7,89 @@ 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_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 - 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 - + 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 + !> 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 + !> 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 - - ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Nørsett, 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 :: 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 ! 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 + ! 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 @@ -114,5 +107,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..0f154af46c 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -4,30 +4,29 @@ !> @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 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. + !> 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 - integer :: iDelay, nFileAccessDelayIterations - real(wp) :: Number, Dummy + integer, intent(in) :: ProcessRank + 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 diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 36655366ab..0c00de90d7 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -7,8 +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 @@ -16,66 +15,66 @@ 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 !> 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 + !> 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 real(wp) :: z @@ -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,356 +126,265 @@ 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 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 ! 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 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 - - 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 - !! 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. - + integer :: geometry !< Type of geometry for the patch + 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. + 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 ! 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 - - 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 - + 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 + 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), 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 - !! 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. - + 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. + !> 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 - - 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 - + 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), 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 - - !! 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 + !> 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 + + ! 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. + !> 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 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. + !> 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) :: G + 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 - integer, dimension(2) :: view + integer, dimension(2) :: view type(vec3_dt), allocatable, dimension(:) :: var end type mpi_io_airfoil_ib_var !> 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 - 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 :: 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 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 - real(wp) :: levelset - real(wp), dimension(1:3) :: levelset_norm - logical :: slip - integer, dimension(3) :: DB - integer :: x_periodicity, y_periodicity, z_periodicity + 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 end type ghost_point !> 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 - - logical :: diffusion - logical :: reactions + character(LEN=name_len) :: cantera_file !< Path to Cantera file + 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 +396,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- @@ -512,16 +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 - end type - + 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 e44b6905c0..f26c203dcd 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -13,51 +13,56 @@ 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 - type(scalar_field), intent(IN) :: fields(1:3) - type(int_bounds_info), intent(IN) :: 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 - 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 @@ -65,34 +70,21 @@ 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 - !! @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 + !> 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 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 @@ -104,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 @@ -116,7 +108,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 +124,8 @@ 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..4074530a8f 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -8,86 +8,58 @@ !> @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; - 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 - !! @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), 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. + !> 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]') - 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. + !> 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 - 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) @@ -110,10 +82,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 @@ -143,11 +112,11 @@ 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 - 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 @@ -198,34 +167,29 @@ contains !> 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 + 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) - ! 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 + ! 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) 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) + ! 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) 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(:) @@ -239,50 +203,44 @@ contains ! Peclet numbers Pe_T(:) = rho_m0*cp_m0(:)/k_m0(:) - ! natural frequencies (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)) - 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) 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) 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 + 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 @@ -290,9 +248,9 @@ contains 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 +258,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 @@ -326,89 +283,62 @@ 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]') 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. + !> Swap two real numbers. 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. + !> Create a 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 @@ -417,50 +347,39 @@ 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 - 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) 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 - 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) + 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. + !> 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) @@ -468,15 +387,12 @@ 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 - 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,52 +400,50 @@ 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. + !> Perform XOR on lhs and rhs. 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.. + !> Convert a logical to 1 or 0. elemental function f_logical_to_int(predicate) result(int) logical, intent(in) :: predicate - integer :: int + integer :: int if (predicate) then int = 1 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. + !> 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 @@ -545,24 +459,24 @@ 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 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 result_P = 0._wp return @@ -570,89 +484,75 @@ 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 + !> Calculate the double factorial of an integer 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 + !> Calculate the factorial of an integer 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 - !! @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 - 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 + !> Calculate a smooth cut-off function that is one for x values smaller than zero and goes to zero, 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 + !> Helper function for f_cut_on and f_cut_off 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) @@ -662,14 +562,14 @@ 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 ! 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 +592,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 @@ -704,20 +604,19 @@ 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 - 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,15 +626,17 @@ 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 diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 0b430cb4d5..7208a451da 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -7,31 +7,24 @@ !> @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; - 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. - !! @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]') - 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 @@ -46,20 +39,19 @@ 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. - !! @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]') - 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. @@ -75,68 +67,62 @@ 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 - - ! 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) + !> 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) - 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 - - ! 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 + logical, intent(in) :: viscous, bubbles_lagrange + logical, intent(in) :: igr + logical, intent(in) :: ib + + ! Determine ghost cell buffer size for boundary conditions + 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 @@ -164,13 +150,11 @@ 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 - integer, intent(in) :: m, n, p + integer, intent(in) :: m, n, p bounds%mn_max = max(m, n) bounds%np_max = max(n, p) diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 9683f4caac..c88bffa7e6 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -11,58 +11,47 @@ 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 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 #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(:) - 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]') + 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 + 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. + !> Read a binary 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 +72,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 @@ -95,23 +84,19 @@ 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 - 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 + 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 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 +165,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 @@ -204,23 +189,18 @@ 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. + !> Read an STL file. impure subroutine s_read_stl(filepath, model) character(LEN=*), intent(in) :: filepath - type(t_model), intent(out) :: model - - integer :: iunit, iostat + type(t_model), intent(out) :: model + integer :: iunit, iostat + character(80) :: line - 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 @@ -240,23 +220,16 @@ 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 - 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 @@ -279,7 +252,7 @@ contains rewind (iunit) - allocate (vertices(nVertices, 1:3)) + allocate (vertices(nVertices,1:3)) allocate (model%trs(model%ntrs)) i = 1 @@ -294,13 +267,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 @@ -316,14 +289,11 @@ 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 - - type(t_model) :: model + type(t_model) :: model select case (filepath(len(trim(filepath)) - 3:len(trim(filepath)))) case (".stl") @@ -338,23 +308,18 @@ 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 - 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 +341,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 @@ -388,20 +353,15 @@ 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 - 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 +373,22 @@ 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. + !> Write a mesh to a file. 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") @@ -446,7 +403,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 @@ -455,13 +412,13 @@ 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 + integer, intent(in) :: iunit character(80), intent(out) :: line - - logical :: bIsLine - integer :: iostat + logical :: bIsLine + integer :: iostat bIsLine = .true. @@ -484,13 +441,13 @@ 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 - character(80), intent(inout) :: buffered_line - logical, intent(inout) :: is_buffered - character(80) :: line + integer, intent(in) :: iunit + character(80), intent(inout) :: buffered_line + logical, intent(inout) :: is_buffered + character(80) :: line if (is_buffered) then line = buffered_line @@ -501,52 +458,44 @@ 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 + !> 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]') integer, intent(inout) :: seed - real(wp) :: rval + real(wp) :: rval seed = ieor(seed, ishft(seed, 13)) seed = ieor(seed, ishft(seed, -17)) 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. - !! @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]') - 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 +506,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 @@ -574,8 +523,7 @@ 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 @@ -583,38 +531,29 @@ 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) $: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 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) @@ -622,82 +561,66 @@ 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) 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 - 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)) 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) - 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)) + ! 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)) - 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 - ! 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 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]') - 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) - ! 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 - 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 @@ -713,24 +636,21 @@ 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 - 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 ! Initialize edge_occurrence array to zero @@ -740,35 +660,35 @@ 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 ! 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 @@ -789,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 @@ -828,66 +748,59 @@ 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 - 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 - !> 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]') - 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) + n(:) = gpu_trs_n(:,i, pid) ! 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 @@ -916,9 +829,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 @@ -926,22 +837,20 @@ 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(:) - dist_e = sqrt((point(1) - proj(1))**2 + & - (point(2) - proj(2))**2 + & - (point(3) - proj(3))**2) + 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 dist_min = dist_e @@ -955,25 +864,22 @@ 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 - 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(:) 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 - 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(:) @@ -987,27 +893,21 @@ 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]') - 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 @@ -1039,12 +939,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) @@ -1063,37 +963,33 @@ 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 - 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) - 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 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,23 +1037,23 @@ 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) - 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 @@ -1209,15 +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 @@ -1229,21 +1124,23 @@ contains end block 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 - 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)) + 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 + + 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..8a719f5758 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -9,35 +9,22 @@ 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 + use m_global_parameters use m_helper - use ieee_arithmetic - use m_nvtx implicit none integer, private :: v_size $: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. + 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 @@ -47,15 +34,12 @@ 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 - ! 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 @@ -65,14 +49,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) @@ -91,56 +71,41 @@ 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 - integer :: ierr !< Generic flag used to identify and report MPI errors + 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 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 + !> 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 - 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 - - ! 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 :: ierr !< Generic flag used to identify and report MPI errors integer :: alt_sys if (present(beta)) then @@ -150,23 +115,23 @@ 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 + ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then 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 @@ -183,49 +148,42 @@ 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 #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) + 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 + !> 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 - - 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 - - ! Generic loop iterator integer :: i, j, q, k, l, m_ds, n_ds, p_ds, ierr sf_start_idx = (/0, 0, 0/) @@ -242,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 @@ -256,32 +214,29 @@ 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. + !> 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 :: 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,28 +247,28 @@ 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. + !> 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 - 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 + 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. + !> 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 print *, "" @@ -324,272 +279,174 @@ 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 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. + 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 #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 - ! 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 if (viscous) then 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 + !> 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 + 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) + 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 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 - 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 + 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) + 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 + !> 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 + integer, intent(in) :: var_loc 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 - ! 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 + !> 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 + 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) + 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 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 + 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) + 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 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. + !> 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 #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_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. + !> Reduce a 2-element variable to its global maximum value with the owning processor rank (MPI_MAXLOC). + !> 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 #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 + 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) - ! 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) + 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 + integer :: ierr !< Generic flag used to identify and report MPI errors #endif if (present(prnt)) then print *, prnt call flush (6) - end if #ifndef MFC_MPI @@ -599,7 +456,6 @@ contains stop 1 end if #else - ! Terminating the MPI environment if (present(code)) then call MPI_ABORT(MPI_COMM_WORLD, code, ierr) else @@ -609,15 +465,13 @@ contains 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 + 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 @@ -626,48 +480,30 @@ 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 - ! 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) + !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the + !! neighboring processors. + 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 :: 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 + integer :: ierr !< Generic flag used to identify and report MPI errors call nvtxStartRange("RHS-COMM-PACKBUF") @@ -676,18 +512,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]') @@ -697,12 +527,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) @@ -746,8 +573,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 +588,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 +603,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 +618,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 +634,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 +650,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 +666,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 +682,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 @@ -877,7 +695,7 @@ contains #:endif end if #:endfor - call nvtxEndRange ! Packbuf + call nvtxEndRange ! Packbuf ! Send/Recv #ifdef MFC_SIMULATION @@ -887,13 +705,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 nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-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 nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA #:endcall GPU_HOST_DATA $:GPU_WAIT() #:else @@ -902,12 +717,10 @@ 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 + call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA call nvtxStartRange("RHS-COMM-HOST2DEV") $:GPU_UPDATE(device='[buff_recv]') @@ -916,10 +729,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 +743,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 +764,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 +779,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 +794,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 +815,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 +831,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 @@ -1038,16 +842,13 @@ 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 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 +869,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 +885,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 @@ -1106,37 +903,19 @@ 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 - - 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 + 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 @@ -1157,10 +936,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,43 +947,26 @@ 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 - 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 @@ -1218,40 +978,24 @@ 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 num_procs_x = 1 num_procs_y = 1 @@ -1262,78 +1006,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. + ! 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) - ! END: 3D Cartesian Processor Topology + call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, proc_coords, ierr) ! Global Parameters for z-direction @@ -1353,16 +1067,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 +1107,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 @@ -1412,7 +1120,6 @@ contains ! 2D Cartesian Processor Topology else - ! Initial estimate of optimal processor topology num_procs_x = 1 num_procs_y = num_procs @@ -1421,58 +1128,38 @@ 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. + ! 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 ! Global Parameters for y-direction @@ -1492,16 +1179,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 +1219,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 @@ -1551,19 +1232,14 @@ contains ! 1D Cartesian Processor Topology else - ! Optimal processor topology 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,16 +1302,11 @@ 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 @@ -1644,14 +1315,9 @@ contains 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. #ifndef MFC_PRE_PROCESS subroutine s_mpi_sendrecv_grid_variables_buffers(mpi_dir, pbc_loc) @@ -1659,171 +1325,66 @@ 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 - ! 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) - + if (pbc_loc == -1) then ! PBC at the beginning + + 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 + 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) - + 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 + 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 - - 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) - + 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 + 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(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) - + 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 + 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) - + if (pbc_loc == -1) then ! PBC at the beginning + + 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 + 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) - + 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 + 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_nvtx.f90 b/src/common/m_nvtx.f90 index 449401128b..66893c10d0 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -9,64 +9,63 @@ 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') & - ] + 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) - 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 + 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 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. + !> 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 - integer, intent(IN), optional :: id - type(nvtxEventAttributes) :: event -#if defined(MFC_GPU) && defined(__PGI) + character(kind=c_char, len=*), intent(in) :: name + integer, intent(in), optional :: id + type(nvtxEventAttributes) :: event - tempName = trim(name)//c_null_char +#if defined(MFC_GPU) && defined(__PGI) + tempName = trim(name) // c_null_char if (.not. present(id)) then call nvtxRangePush(tempName) @@ -75,15 +74,17 @@ 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. + !> Pop 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..21926411db 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -9,35 +9,26 @@ 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; - 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 - 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 @@ -45,55 +36,46 @@ 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. + !> 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 - ! 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) + !> Initialize the phase change module by setting saturation curve coefficients for 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)) + + ! 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)) - C = (gs_min(vp)*cvs(vp) - gs_min(lp)*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)) + 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 + !> 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 - 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 - + 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]') + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok #:else @@ -101,35 +83,31 @@ 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]') + + $: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,33 +127,26 @@ 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 - ! 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) - 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. + ! 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 + ! 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 @@ -187,8 +158,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,7 +172,6 @@ contains ! checking the conditions for overheated vapor and subcooled liquide if (TSOV > TSatOV) then - ! Assigning pressure pS = pSOV @@ -214,9 +183,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,11 +195,8 @@ 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 + ! returning partial pressures to what they were from the homogeneous solver liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = m1 ! vapor @@ -240,9 +204,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 +212,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,7 +241,6 @@ contains ! Total entropy rhos = rhos + q_cons_vf(i + contxb - 1)%sf(j, k, l)*sk(i) - end do end do end do @@ -294,32 +249,22 @@ 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) + + $: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 $:GPU_LOOP(parallelism='[seq]') @@ -330,13 +275,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,11 +293,8 @@ 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 @@ -362,22 +302,20 @@ contains return 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 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,20 +326,16 @@ 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 @@ -409,42 +343,32 @@ 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) - integer, intent(in) :: j, k, l - real(wp), intent(inout) :: pS - real(wp), dimension(1:), intent(in) :: p_infpT - real(wp), intent(in) :: rhoe + $: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 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 + 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) :: ml, mT, dFdT, dTdm, dTdp + 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 + !> 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 @@ -452,62 +376,45 @@ 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 - ! 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)) + 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 ! 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 - 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) - ! 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)) - 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,62 +423,41 @@ 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) - - 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)) - - 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 - - ! 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 + 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) + + 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 + + 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 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 - 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) @@ -592,8 +478,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 @@ -602,124 +487,91 @@ 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) ! 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 + !> 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) + + $: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. - ! 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? 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 + !> 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) - - real(wp), intent(in) :: pSat - real(wp), intent(out) :: TSat - real(wp), intent(in) :: TSIn - real(wp) :: dFdT, FT, Om !< auxiliary variables + $:GPU_ROUTINE(function_name='s_TSat',parallelism='[seq]', cray_noinline=True) + real(wp), intent(in) :: pSat + real(wp), intent(out) :: TSat + 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 - ! 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 @@ -728,9 +580,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)) @@ -738,33 +589,25 @@ 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 + !> Finalize 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 9874ccd87f..7c730cf303 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -7,23 +7,22 @@ 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 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 +42,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..9fdae1258b 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -8,23 +8,17 @@ !> @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 + 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,122 +32,91 @@ 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 + ! 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]') + $: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 - !> 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) + !> Dispatch to the s_convert_mixture_to_mixture_variables and s_convert_species_to_mixture_variables subroutines. Replaces a + !! procedure pointer. + 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 + 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) - + 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) + 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) + !> 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) - - 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 - ! 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 + ! MHD pressure: subtract magnetic pressure from total energy 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 + ! 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 - pres = (pref + pi_inf)* & - (energy/ & - (rhoref*(1 - alf)) & - )**(1/gamma + 1) - pi_inf + ! 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 @@ -165,16 +128,10 @@ 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 - + ! Reacting mixture pressure from temperature and species Y_rs(:) = rhoYks(:)/rho e_Per_Kg = energy/rho Pdyn_Per_Kg = dyn_p/rho @@ -183,41 +140,28 @@ 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 - subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv) + !> 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 - integer, intent(in) :: i, j, k + integer, intent(in) :: i, j, k + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv - real(wp), 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 - ! Transferring the density, the specific heat ratio function and the - ! liquid stiffness function, respectively rho = q_vf(1)%sf(i, j, k) gamma = q_vf(gamma_idx)%sf(i, j, k) pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) - qv = 0._wp ! keep this value nill for now. For future adjustment + 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 @@ -229,48 +173,28 @@ 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) - 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 !< + !> 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 + 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 + ! Computing the density, the specific heat ratio function and the liquid stiffness function, respectively - 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) - ! 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) @@ -293,8 +217,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) @@ -320,33 +243,25 @@ 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. - 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) + !> 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 - ! 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) @@ -374,8 +289,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) @@ -388,8 +302,7 @@ 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) @@ -399,14 +312,12 @@ 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 - $: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,10 +338,9 @@ 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 - if (viscous) then @:ALLOCATE(Res_vc(1:2, 1:Re_size_max)) do i = 1, 2 @@ -439,7 +349,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 @@ -452,80 +362,47 @@ 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 - ! 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. + !> 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 do j = idwint(1)%beg, idwint(1)%end - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) $:GPU_LOOP(parallelism='[seq]') @@ -538,27 +415,24 @@ 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. + !> 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 do j = idwint(1)%beg, idwint(1)%end - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) $:GPU_LOOP(parallelism='[seq]') @@ -566,11 +440,15 @@ 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 @@ -578,55 +456,45 @@ contains 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 - 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 + !> 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. + 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,24 +506,24 @@ 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 + ! Relativistic MHD primitive variable recovery, Mignone & Bodo A&A (2006) if (relativity) then if (n == 0) then B(1) = Bx0 @@ -692,23 +560,24 @@ 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 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) + ! The first equation below corrects a typo in (Mignone & Bodo, 2006) m2*W**2 -> 2*m2*W**2, which would + ! cancel with the 2* in other terms This corrected version is not used as the second equation + ! empirically converges faster. First equation is kept for further investigation. dGa_dW = -Ga**3 * ( + ! S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) + dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) dp_dW = (Ga*(1 + D*dGa_dW) - 2*W*dGa_dW)/((gamma_K + 1)*Ga**3) df_dW = 1 - dp_dW + (B2/Ga**3)*dGa_dW + S**2/W**3 dW = -f/df_dW W = W + dW - if (abs(dW) < 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 @@ -720,17 +589,18 @@ 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 + ! 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 @@ -747,6 +617,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) @@ -757,16 +628,15 @@ 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) + 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) + ! 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 @@ -781,18 +651,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 @@ -801,6 +671,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) @@ -809,19 +680,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 +727,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,7 +762,6 @@ 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 @@ -900,41 +769,33 @@ contains 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) + !> Convert primitives (rho, u, p, alpha) to conserved variables (rho*alpha, rho*u, E, alpha). + 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(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 - + ! Density, specific heat ratio function, liquid stiffness function and dynamic pressure, as defined in the incompressible + ! flow sense, respectively + real(wp) :: rho + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp) :: dyn_pres + real(wp) :: nbub, R3tmp + real(wp), dimension(nb) :: Rtmp + real(wp) :: G + real(wp), dimension(2) :: Re_K + integer :: i, j, k, l !< Generic loop iterators real(wp), dimension(num_species) :: Ys - real(wp) :: e_mix, mix_mol_weight, T - real(wp) :: pres_mag - - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: h ! relativistic enthalpy - real(wp) :: v2 ! Square of the velocity magnitude - real(wp) :: B2 ! Square of the magnetic field magnitude - real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors - real(wp) :: B(3) ! Magnetic field components + 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 +806,8 @@ 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) + ! 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 ! Transferring the advection equation(s) variable(s) @@ -959,7 +817,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) @@ -978,7 +835,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 @@ -996,12 +853,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) @@ -1011,8 +866,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) @@ -1020,18 +874,17 @@ 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 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 + ! 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) @@ -1041,41 +894,38 @@ 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 - ! 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 + ! 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 + ! 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) - 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) + ! 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) + 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 +943,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 @@ -1115,8 +965,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 @@ -1127,12 +976,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 +1002,66 @@ 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 - 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 + !> 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 + + ! 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 + ! 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 +1085,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 +1098,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 +1106,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 +1117,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 +1137,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 +1148,27 @@ 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 + !> 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) + + $: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 @@ -1383,11 +1208,10 @@ 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 + ! 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 @@ -1407,8 +1231,9 @@ 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]') real(wp), intent(in) :: pres @@ -1419,49 +1244,39 @@ 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 (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 - elseif (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 - blkmod1 = ((gammas(1) + 1._wp)*pres + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1._wp)*pres + & - pi_infs(2))/gammas(2) + 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))) - elseif (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 - 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 @@ -1473,21 +1288,21 @@ contains c = sqrt(c) end if end if + 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. + !> 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) - 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 + $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) - real(wp) :: B2, term, disc + real(wp), intent(in) :: B(3), rho, c + real(wp), intent(in) :: h !< only used for relativity + real(wp), intent(out) :: c_fast + integer, intent(in) :: norm + real(wp) :: B2, term, disc B2 = sum(B**2) @@ -1511,5 +1326,4 @@ contains 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..c46bc8fd0b 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -7,12 +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 @@ -21,13 +18,14 @@ module m_checker 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 @:PROHIBIT(fft_wrt .and. MOD(n_glb+1,n+1) /= 0, "FFT WRT requires n_glb to be divisible by num_procs_y") @@ -36,6 +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 be1bdcb2d2..3a75c391f2 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -6,35 +6,25 @@ 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 - use m_helper 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 impure subroutine s_read_abstract_data_files(t_step) implicit none @@ -42,23 +32,13 @@ impure subroutine s_read_abstract_data_files(t_step) 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 !< - !! 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 @@ -67,69 +47,49 @@ 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 - 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 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 #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 + 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 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) @@ -142,29 +102,26 @@ 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=*), 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) @@ -178,7 +135,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) @@ -188,95 +145,64 @@ 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') - read (2) ib_markers%sf(0:m, 0:n, 0:p) + 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 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)) - 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 - !> 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 - - 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 + 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 + character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir + logical :: dir_check + logical :: file_check + integer :: i - 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) + 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 @@ -285,7 +211,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 @@ -296,69 +221,48 @@ 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' + 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) + 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 - ! 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 + ! 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.') + 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 + !> 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 #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)) @@ -370,8 +274,7 @@ 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' + 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,19 +290,15 @@ 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 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' + 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,19 +314,15 @@ 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 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' + 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,14 +338,11 @@ 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 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 @@ -464,35 +356,29 @@ 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 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 @@ -501,7 +387,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 @@ -510,14 +395,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) @@ -526,18 +408,15 @@ 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) - 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 @@ -546,18 +425,17 @@ 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 - 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 @@ -565,77 +443,61 @@ 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) - 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 + integer :: i - ! 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 - - ! 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 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 - ! 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: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 @@ -650,9 +512,8 @@ end subroutine s_initialize_data_input_module !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module - integer :: i !< Generic loop iterator + integer :: i - ! Deallocating the conservative and primitive variables do i = 1, sys_size deallocate (q_cons_vf(i)%sf) deallocate (q_prim_vf(i)%sf) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 3251b3ac3b..0ac093288f 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -5,187 +5,129 @@ !> @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 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 - - ! 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' + 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 + + ! 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. - real(wp), allocatable, dimension(:, :, :), public :: q_sf - real(wp), allocatable, dimension(:, :, :) :: q_root_sf - real(wp), allocatable, dimension(:, :, :) :: cyl_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 ! 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 - - ! 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. + real(sp), allocatable, dimension(:,:,:), public :: q_sf_s + real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s + real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s + + ! Spatial and data extents for VisIt visualization + real(wp), allocatable, dimension(:,:) :: spatial_extents + real(wp), allocatable, dimension(:,:) :: data_extents + + ! Ghost zone layer sizes (lo/hi) for subdomain connectivity in VisIt integer, allocatable, dimension(:) :: lo_offset integer, allocatable, dimension(:) :: hi_offset - ! 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 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 + 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. + !> 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 + logical :: dir_check + integer :: i - ! 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 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 - ! 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)) + 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)) - elseif (n > 0) then - allocate (spatial_extents(1:4, 0:num_procs - 1)) + else if (n > 0) then + allocate (spatial_extents(1:4,0:num_procs - 1)) allocate (lo_offset(1:2)) allocate (hi_offset(1:2)) allocate (dims(1:2)) 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)) 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 @@ -197,20 +139,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/) @@ -218,49 +157,38 @@ 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' + 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 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' - 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) @@ -268,27 +196,23 @@ 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' - 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 @@ -297,74 +221,50 @@ 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 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 + 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 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 @@ -373,83 +273,57 @@ 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 + 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 - ! 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 + 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 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 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. + !> 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 + 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,126 +344,63 @@ 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. + !> 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. - - ! Time-step that is currently being post-processed - 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 - ! Silo-HDF5 Database Format + integer, intent(in) :: t_step + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc + 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) + 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 - ! 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 + 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 - ! 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) + 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,221 +408,140 @@ 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. + !> 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) + 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. + !> 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) + 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. + !> 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. - 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 + integer, intent(in) :: t_step - ! Silo-HDF5 Database Format + ! NAG compiler requires these to be statically sized + character(LEN=4*name_len), dimension(num_procs) :: meshnames + integer, dimension(num_procs) :: meshtypes + 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 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) - 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)/) + 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' + 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 - ! 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) 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 - - ! Multidimensional local grid data is written to the formatted - ! database slave file. Recall that no master file to maintained - ! in multidimensions. + 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 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 write (dbfile) real(x_cb, sp) else @@ -839,69 +569,34 @@ 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. + !> 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 - - ! 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. - character(LEN=4*name_len), dimension(num_procs) :: varnames - integer, dimension(num_procs) :: vartypes - ! Generic loop iterator - integer :: i, j, k + character(LEN=*), intent(in) :: varname + integer, intent(in) :: t_step - integer :: ierr !< Generic flag used to identify and report database errors - - ! Silo-HDF5 Database Format + ! NAG compiler requires these to be statically sized + character(LEN=4*name_len), dimension(num_procs) :: varnames + integer, dimension(num_procs) :: vartypes + 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 + ! 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)/) + 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) + write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) end do vartypes = DB_QUADVAR @@ -910,17 +605,11 @@ 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 - ! 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 @@ -950,7 +639,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,62 +662,37 @@ 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 - - ! 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 + ! 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) else - q_root_sf(:, :, :) = q_sf(:, :, :) + q_root_sf(:,:,:) = q_sf(:,:,:) end if if (proc_rank == 0) then @@ -1038,58 +702,50 @@ 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 + !> 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 - + 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 + 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 - 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 +764,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 +783,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)) + 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') @@ -1174,13 +824,16 @@ 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, ', ' - 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), ', ' @@ -1207,59 +860,52 @@ 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 - + 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 +924,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,62 +953,49 @@ 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'] 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_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) - ! 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), & ('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 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' + 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 +1015,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 +1035,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 +1064,95 @@ 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. + !> 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 + 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 + !> 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 - 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 @@ -1557,12 +1164,12 @@ 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 - integer :: i, j, k, l, cent !< Generic loop iterators - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + 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 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 @@ -1598,8 +1205,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 +1217,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 +1241,24 @@ 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. + !> 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 + + 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 + integer :: i, j, k, l, s !< looping indices Egk = 0._wp Elp = 0._wp @@ -1698,9 +1304,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,80 +1337,52 @@ 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. + !> 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) - end if 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() - ! 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 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) diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 0407d06485..daa9ca6dbf 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -6,101 +6,54 @@ 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 - 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. + private; public :: s_initialize_derived_variables_module, s_derive_specific_heat_ratio, s_derive_liquid_stiffness, & + & s_derive_sound_speed, s_derive_flux_limiter, s_derive_vorticity_component, s_derive_qm, s_derive_liutex, & + & s_derive_numerical_schlieren_function, s_compute_speed_of_sound, s_finalize_derived_variables_module + + real(wp), allocatable, dimension(:,:,:) :: gm_rho_sf !< Density gradient magnitude for numerical Schlieren + !> @name Finite-difference (fd) coefficients in x-, y- and z-coordinate directions. Note that because sufficient boundary + !! information is available for all the active coordinate directions, the centered family of the finite-difference schemes is + !! used. !> @{ - real(wp), allocatable, dimension(:, :), public :: fd_coeff_x - real(wp), allocatable, dimension(:, :), public :: fd_coeff_y - real(wp), allocatable, dimension(:, :), public :: fd_coeff_z + 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 !< - !! 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 !< Dimensionality flag: 1 = 3D dataset, 0 = otherwise 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 + ! 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 - ! 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 - 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- - ! 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 @@ -109,22 +62,14 @@ 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), & - intent(inout) :: q_sf - - integer :: i, j, k !< Generic loop iterators + 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 - ! 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 @@ -135,24 +80,15 @@ 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, 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 + !> 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. 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 - - integer :: i, j, k !< Generic loop iterators + 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 - ! 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 @@ -163,49 +99,30 @@ 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 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 + !> 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. 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 + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer :: i, j, k !< Generic loop iterators + 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 - ! Fluid bulk modulus for alternate sound speed + integer :: i, j, k real(wp) :: blkmod1, blkmod2 - ! 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))) + 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 @@ -219,66 +136,44 @@ 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 - + 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) :: top, bottom, slope !< Flux limiter calcs - integer :: j, k, l !< Generic loop iterators + 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 + 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 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 @@ -287,72 +182,58 @@ 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 - ! Flux limiter function - 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)) - 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 + !> Solve Ax=b via Gaussian elimination with partial pivoting 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 + integer :: i, j, k - !EXTERNAL DGESV + ! Forward elimination with partial pivoting - integer :: i, j, k - - ! 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) - sol = A(i, :) - A(i, :) = A(j, :) - A(j, :) = sol + j = i - 1 + maxloc(abs(A(i:ndim,i)), 1) + 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 - ! Backward substitution do i = ndim, 1, -1 sol(i) = b(i) do k = i + 1, ndim @@ -362,104 +243,64 @@ 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 - - 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 + integer, intent(in) :: i + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer :: j, k, l, r !< Generic loop iterators + 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 - ! 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 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 - - ! 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 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 @@ -467,156 +308,110 @@ 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 - - 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 + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp) :: trS, Q, IIS - integer :: j, k, l, r, jj, kk !< Generic loop iterators + 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 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 + ! 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)) - 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-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) - IIS = 0.5_wp*((S(1, 1) + S(2, 2) + S(3, 3))**2 - & - (S2(1, 1) + S2(2, 2) + S2(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 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 + !> 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) - 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 - - 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 + + ! 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 + + !> 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 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 + 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 + 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 @@ -627,19 +422,17 @@ 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 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) + 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,22 +440,21 @@ 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 + ! 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 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 @@ -673,50 +465,28 @@ 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 + !> 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 - - 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_cons_vf - real(wp) :: drho_dx, drho_dy, drho_dz !< - !! Spatial derivatives of the density in the x-, y- and z-directions + 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(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. + 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 - integer :: i, j, k, l !< Generic loop iterators - - ! Computing Gradient Magnitude of Density - - ! 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 - drho_dx = 0._wp drho_dy = 0._wp @@ -726,101 +496,73 @@ contains end do gm_rho_sf(j, k, l) = drho_dx*drho_dx + drho_dy*drho_dy - end do 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 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 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. 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 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. 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 + 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 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 + !> 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) diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index c92f0725be..0530c31081 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -8,27 +8,24 @@ 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 + use m_helper_basic 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 - 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 @@ -38,8 +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) !> @{ @@ -52,9 +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 @@ -71,235 +66,183 @@ 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. - + 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 - !> @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 - ! 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 !> @{ - 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 + 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). - ! 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 (InDices With BUFFer): includes buffer in simulation only 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, 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 :: 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 :: 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 #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 !< - !! 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 !< 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 - + 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 - - !> @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. + 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. !> @{ 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 for case-optimization + GPU-kernel bug + 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 !< - !! 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. - + 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 @@ -321,8 +264,7 @@ module m_global_parameters 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 real(wp) :: G real(wp) :: poly_sigma real(wp) :: sigR @@ -331,9 +273,8 @@ module m_global_parameters !> @name surface tension coefficient !> @{ - real(wp) :: sigma - logical :: surface_tension + logical :: surface_tension !> @} !> @name Index variables used for m_variables_conversion @@ -353,20 +294,18 @@ 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 - !> 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 - + integer :: i !< Generic loop iterator ! Logistics + case_dir = '.' ! Computational domain parameters @@ -452,8 +391,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 @@ -556,24 +495,22 @@ contains 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 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 @@ -587,10 +524,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 @@ -598,17 +533,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 - adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 + ! 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 @@ -626,7 +558,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 @@ -683,19 +614,17 @@ 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 ! 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 @@ -706,18 +635,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 @@ -762,7 +690,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 @@ -778,18 +705,16 @@ 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/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + 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 @@ -821,7 +746,6 @@ contains else psi_idx = dflt_int end if - end if if (chemistry) then @@ -870,58 +794,46 @@ 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 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 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 - ! 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) + ! 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 fd_number = max(1, fd_order/2) @@ -950,7 +862,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)) @@ -961,26 +872,24 @@ 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)) allocate (x_root_cc(0:m_root)) 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 + 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 + else ! Fully 3D cylindrical grid grid_geometry = 3 end if @@ -990,7 +899,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) @@ -1006,20 +915,16 @@ 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) 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 @@ -1030,6 +935,7 @@ contains 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 @@ -1039,8 +945,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 @@ -1049,7 +955,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 d0a1311f4e..c91f140d39 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -6,22 +6,18 @@ 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 + use m_global_parameters use m_mpi_common - use ieee_arithmetic 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 @@ -29,28 +25,23 @@ module m_mpi_proxy 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. - 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. 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,25 +52,20 @@ 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 - + 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', & @@ -152,248 +138,166 @@ 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. - !! @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 + 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 - - ! 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) - 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. + !> 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 - 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 - call MPI_GATHERV(x_cc(0), m + 1, mpi_p, & - x_root_cc(0), recvcounts, displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + 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) ! 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. + !> 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 - 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 + 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) + ! 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) + 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) - 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 + !> 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 + 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 - call MPI_GATHERV(q_sf(0), m + 1, mpi_p, & - q_root_sf(0), recvcounts, displs, & - mpi_p, 0, MPI_COMM_WORLD, ierr) + 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 + 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 @@ -402,14 +306,11 @@ 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 + ! 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 diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 7ae3dbfebe..c65e4cf7cf 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -8,133 +8,82 @@ 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 - use m_checker - use m_thermochem, only: num_species, species_names - use m_finite_differences - use m_chemistry #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif implicit none 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 - - logical :: file_check !< - !! Generic logical used for the purpose of asserting whether a file - !! is or is not present in the designated location - - 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 - 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 + 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, & + & 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 + 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') + 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) @@ -147,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 @@ -156,40 +104,30 @@ 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 - - logical :: dir_check !< - !! Logical variable used to test the existence of folders + character(LEN=len_trim(case_dir)) :: file_loc + logical :: dir_check - ! 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() @@ -197,59 +135,53 @@ 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 + 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 + & 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 - ! 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 - !> @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 + 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 @@ -268,7 +200,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 @@ -281,35 +212,24 @@ 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) + 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 +238,12 @@ 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 +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) @@ -341,54 +259,47 @@ 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 - q_sf(:, :, :) = q_cons_vf(1)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + ! 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) 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) + 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 - ! 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 - 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) @@ -396,10 +307,8 @@ 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) write (varname, '(A,I0)') 'flux', i @@ -409,21 +318,18 @@ 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) + 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 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) @@ -432,9 +338,7 @@ contains end do end if - !Adding Energy cascade FFT if (fft_wrt) then - do l = 0, p do k = 0, n do j = 0, m @@ -450,7 +354,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 +367,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 +384,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 +409,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 +441,11 @@ 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 +458,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' @@ -568,11 +470,10 @@ 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 - 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 +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 @@ -592,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) @@ -600,42 +501,33 @@ 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) 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) + 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,66 +540,49 @@ 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 if (c_wrt) then do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end @@ -718,12 +593,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 +607,10 @@ 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,12 +621,12 @@ 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 - ! Adding Q_M to the formatted database file if (p > 0 .and. qm_wrt) then call s_derive_qm(q_prim_vf, q_sf) @@ -766,13 +636,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' @@ -780,78 +646,69 @@ contains varname(:) = ' ' - ! 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(:) = ' ' end do end if - ! 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,26 +717,23 @@ 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(:) = ' ' 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, & - -offset_z%beg:p + offset_z%end) + ! 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' 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 @@ -887,19 +741,18 @@ 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 - !> @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(:) - integer :: dest_rank, src_rank - integer :: i, j, k, l + integer :: dest_rank, src_rank + integer :: i, j, k, l #ifdef MFC_MPI - allocate (sendbuf(Nx*Nyloc*Nzloc)) allocate (recvbuf(Nx*Nyloc*Nzloc)) @@ -907,20 +760,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,19 +783,18 @@ 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. + !> 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 - allocate (sendbuf(Ny*Nxloc*Nzloc)) allocate (recvbuf(Ny*Nxloc*Nzloc)) @@ -948,20 +802,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,15 +826,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. + !> 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() @@ -994,7 +849,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 @@ -1003,7 +857,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 +886,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,18 +914,17 @@ 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. + !> 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 - do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nx @@ -1139,23 +982,17 @@ 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. + !> 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. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1164,9 +1001,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() @@ -1174,15 +1008,10 @@ 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 - ! 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 + s_read_data_files => null() if (fft_wrt) then if (c_associated(fwd_plan_x)) call fftw_destroy_plan(fwd_plan_x) @@ -1206,7 +1035,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() @@ -1217,8 +1045,8 @@ contains end if call s_finalize_global_parameters_module() - ! 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..32d8dc2c7e 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -2,31 +2,21 @@ !! @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. +!> Post-process raw simulation data into formatted database files (Silo-HDF5 or Binary) program p_main - use m_global_parameters !< Global parameters for the code + use m_global_parameters 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() @@ -42,12 +32,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) @@ -71,14 +58,10 @@ 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 - elseif (t_step == t_step_stop) then + else if (t_step == t_step_stop) then exit end if end if @@ -89,7 +72,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 +82,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..e171097d4b 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -8,14 +8,10 @@ !> @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_derived_types + use m_global_parameters + use m_variables_conversion + use m_helper_basic use m_thermochem, only: num_species, gas_constant, get_mixture_molecular_weight implicit none @@ -24,193 +20,127 @@ 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 - - !> 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 + !> 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 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) + !> Skeleton of s_assign_patch_mixture_primitive_variables and s_assign_patch_species_primitive_variables + 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 + 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 - 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. + !> Allocate volume fraction sum and set 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)) + 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 - else ! Volume fraction model - s_assign_patch_primitive_variables => & - s_assign_patch_species_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 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). - !! @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) + !> 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]') - 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 + 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) + integer :: smooth_patch_id + integer :: i - 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 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 - - ! 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 + 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(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(pi_inf_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%pi_inf + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf + 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) + 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 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 + 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 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 - !> @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 + 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 +154,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 @@ -273,152 +204,112 @@ 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 - impure subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + !> 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]') - 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 + 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 - ! 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(stp), dimension(sys_size) :: orig_prim_vf !< - !! Vector to hold original values of cell for smoothing purposes + ! Density, gamma, and liquid stiffness from 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(stp), dimension(sys_size) :: orig_prim_vf !< Vector to hold original values of cell for smoothing purposes + integer :: i + integer :: smooth_patch_id - 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 - ! Transferring original primitive variables do i = 1, sys_size orig_prim_vf(i) = q_prim_vf(i)%sf(j, k, l) 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) - - ! Computing Mixture Variables of Current Patch + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, orig_rho, orig_gamma, orig_pi_inf, orig_qv) 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 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 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 + 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) 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 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 - ! Bubbles euler variables if (bubbles_euler) then do i = 1, nb muR = R0(i)*patch_icpp(smooth_patch_id)%r0/R0ref @@ -460,67 +351,42 @@ 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) + 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) - 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) + 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 + 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 + 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,67 +399,52 @@ 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 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) + 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 @@ -602,10 +453,8 @@ 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 + 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 +462,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 @@ -625,7 +474,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 @@ -655,7 +503,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 +517,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 @@ -686,7 +532,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) @@ -695,30 +540,16 @@ 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 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. + !> Nullify 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 diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 46cbbda47c..70c3485a12 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -6,36 +6,32 @@ 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 - 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 !< - + 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. + !> 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 + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer, intent(in) :: patch_id + integer :: j - integer :: j + ! Patch is a line segment along y on the x-boundary face - ! 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) @@ -43,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 @@ -55,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) @@ -63,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 @@ -77,14 +73,13 @@ 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 + 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 +89,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 +106,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 +122,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 @@ -141,13 +133,13 @@ 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 + 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) @@ -159,15 +151,13 @@ 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 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 @@ -186,15 +176,13 @@ 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 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 +205,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 @@ -231,14 +217,15 @@ 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 - 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 - !< Apply 2D patches to 3D domain if (p > 0) then do i = 1, num_bc_patches if (proc_rank == 0) then @@ -247,12 +234,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 + !> Apply 1D patches to 2D domain + else if (n > 0) then do i = 1, num_bc_patches if (proc_rank == 0) then print *, 'Processing boundary condition patch', i diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index ea481d2e91..844d051716 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -8,45 +8,36 @@ 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 + 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 - 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. + !> Validate 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 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 @@ -63,265 +54,173 @@ 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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 + !> 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 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_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 - !! 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 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 diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 6725faba75..adcb233f97 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -11,23 +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 + 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 @@ -38,64 +31,64 @@ 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 + integer :: i character(len=10) :: num_patches_str call s_int_to_str(num_patches, num_patches_str) 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.") - @: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 +104,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) @@ -139,25 +125,26 @@ 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 + 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 - !> 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 + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Circle patch "//trim(iStr)//": n must be zero") @@ -168,11 +155,11 @@ 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 + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Rectangle patch "//trim(iStr)//": n must be greater than zero") @@ -184,11 +171,11 @@ 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 + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Line sweep patch "//trim(iStr)//": n must be greater than zero") @@ -197,15 +184,16 @@ 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 - !! @param patch_id Patch identifier + !> Check the ellipse patch input 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") @@ -218,28 +206,33 @@ 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 + 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") - @: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 - !! @param patch_id Patch identifier + !> Check the model patch input 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") @@ -250,7 +243,9 @@ 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 call s_int_to_str(patch_id, iStr) @@ -263,25 +258,31 @@ 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 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 - !! @param patch_id Patch identifier + !> Check the model patch input 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") @@ -294,12 +295,12 @@ 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 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") @@ -309,27 +310,25 @@ 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 + !> Check the model patch input 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") @@ -342,11 +341,11 @@ 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 + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Ellipsoid patch "//trim(iStr)//": p must be greater than zero") @@ -359,17 +358,19 @@ 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 + 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") @@ -385,168 +386,154 @@ 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 + 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 + !> Verify that inactive patches cannot overwrite other patches 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") + @: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 + !> Check the smoothing parameters 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 + !> Verify that inactive patches cannot be smoothed 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)%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 + !> Check the primitive variables 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(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") + & "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) 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") + & "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 + !> 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 + 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") + & "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. + !> 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 - - 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 diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index 63ed19199b..bd6ca48ee0 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -7,12 +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 @@ -21,9 +18,9 @@ module m_checker 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..ab3257a77b 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -5,116 +5,70 @@ !> @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 - 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 - 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 - !! @param q_cons_vf Conservative variables + !> Interface for the conservative data 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 - 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 - !> 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 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(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 - - 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 + 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 @@ -122,8 +76,6 @@ contains t_step = 0 - ! Outputting the Locations of the Cell-boundaries - if (old_grid) then status = 'old' else @@ -138,52 +90,40 @@ 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) + 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 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' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) - write (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) + 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 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 +131,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 +150,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 +159,13 @@ 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 - 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,40 +178,34 @@ 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 + 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 - if (qbmm) then nbub = q_cons_vf(bubxb)%sf(j, 0, 0) else @@ -301,7 +231,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 +243,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 +255,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 @@ -342,10 +274,9 @@ 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' + 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 +290,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 +304,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 @@ -392,10 +325,9 @@ 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' + 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 +344,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 +360,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 @@ -445,43 +379,27 @@ 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 + !> 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) - ! 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 - - ! 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 + logical :: file_exist, dir_check + 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 @@ -491,17 +409,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)) @@ -511,36 +429,31 @@ 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 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 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 @@ -556,21 +469,17 @@ 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) + 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) - 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,39 +487,33 @@ 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) - ! Open the file to write all flow variables if (cfl_dt) then write (file_loc, '(I0,A)') n_start, '.dat' 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) ! Resize some integers so MPI can write even the biggest files @@ -622,47 +525,34 @@ 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) + 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) - 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, 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) + 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) @@ -679,50 +569,37 @@ contains 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'/) - - ! Generic logical used to check the existence of directories - logical :: dir_check - integer :: i - integer :: m_ds, n_ds, p_ds !< down sample dimensions + 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'/) + 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) + 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. 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 +609,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 +620,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 @@ -781,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 886294f515..077262aece 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -8,241 +8,171 @@ 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 - - logical :: cfl_adap_dt, cfl_const_dt, cfl_dt - integer :: n_start, n_start_old + 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) - - 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 - - ! 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. + 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 + ! 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 + 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 - 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 + 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 - - ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). - ! Stands for "InDices With BUFFer". + 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 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 - 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 - logical :: simplex_perturb + ! 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 + 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 - - 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 !< - !! Processor coordinates in MPI_CART_COMM - - integer, allocatable, dimension(:) :: start_idx !< - !! Starting cell-center index of local processor in global grid - + 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 #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 - + 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 - - 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 - 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 + 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 - 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. - + 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 - - 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 - - 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. - + 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 !< Immersed boundary patch parameters + type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l !> @} !> @name Non-polytropic bubble gas compression @@ -250,25 +180,19 @@ 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 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,31 +207,23 @@ 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 !< - !! 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 + 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 !< Number of ghost cells for boundary condition storage + logical :: fft_wrt + logical :: dummy !< AMDFlang workaround for case-optimization + GPU-kernel bug 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 - + integer :: i !< Generic loop operator ! Logistics + case_dir = '.' old_grid = .false. old_ic = .false. @@ -413,11 +329,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 +389,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,8 +533,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 @@ -626,31 +542,27 @@ contains 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 - ! 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 @@ -664,10 +576,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 @@ -675,17 +585,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 @@ -702,7 +609,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 @@ -724,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 @@ -760,19 +667,17 @@ 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 ! 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 @@ -783,18 +688,17 @@ 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 - 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 @@ -835,12 +739,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 @@ -856,18 +758,16 @@ 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/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + 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 @@ -895,7 +795,6 @@ contains psi_idx = sys_size + 1 sys_size = psi_idx end if - end if if (chemistry) then @@ -921,14 +820,10 @@ 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 - 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)) @@ -939,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 @@ -961,25 +856,25 @@ contains end if end if - if (cyl_coord .neqv. .true.) then ! Cartesian grid + 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 + else ! Fully 3D cylindrical grid grid_geometry = 3 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 - !> @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 - 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) @@ -995,30 +890,27 @@ 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) 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. + !> Deallocate 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 @@ -1031,7 +923,6 @@ contains deallocate (proc_coords) #ifdef MFC_MPI - if (parallel_io) then deallocate (start_idx) do i = 1, sys_size @@ -1041,7 +932,6 @@ contains deallocate (MPI_IO_DATA%var) deallocate (MPI_IO_DATA%view) end if - #endif end subroutine s_finalize_global_parameters_module diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 6ea71bd592..77cb02cef2 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -5,52 +5,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_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 #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. + !> 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. + !> Generate a uniform or stretched rectilinear grid in serial from user parameters. 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) - ! Grid Generation in the x-direction dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) do i = 0, m @@ -60,8 +47,8 @@ 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 x_a = x_a/length @@ -69,10 +56,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 +67,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 + ! 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 @@ -100,22 +83,19 @@ 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) do i = 0, n 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 + ! Hyperbolic tangent grid stretching in y-direction if (stretch_y) then - length = abs(y_cb(n) - y_cb(-1)) y_cb = y_cb/length y_a = y_a/length @@ -123,10 +103,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 +114,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 @@ -151,8 +128,8 @@ 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 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,44 +148,33 @@ 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. + !> Generate a uniform or stretched rectilinear grid in parallel from user parameters. 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 - - integer :: ifile, ierr, data_size + 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)) - ! 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)) @@ -221,20 +185,17 @@ 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 - + ! 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 @@ -258,15 +219,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,53 +243,45 @@ 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 diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 25a88f36f9..a565a1b0b3 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -12,77 +12,49 @@ !> @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_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 !< Functions to compare floating point numbers - + use m_helper_basic use m_helper - use m_mpi_common - use m_assign_variables - use m_mpi_common - use m_variables_conversion implicit none 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 - 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. - - 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 + 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 - !> @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 + #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 ! 3D Patch Geometries - if (p > 0) then + if (p > 0) then do i = 1, num_patches - if (proc_rank == 0) then print *, 'Processing patch', i end if @@ -93,35 +65,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 +102,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 !> @} @@ -165,9 +135,7 @@ contains ! 1D Patch Geometries else - do i = 1, num_patches - if (proc_rank == 0) then print *, 'Processing patch', i end if @@ -176,31 +144,25 @@ 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. - !! @param patch_id patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !> 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. 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 + 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 @@ -209,6 +171,7 @@ contains ! Placeholders for the cell boundary values real(wp) :: pi_inf, gamma, lit_gamma + @:HardcodedDimensionsExtrusion() @:Hardcoded1DVariables() @@ -222,28 +185,18 @@ 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. + ! 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 - - 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,38 +207,32 @@ 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. - !! @param patch_id patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !> 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. 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 + 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 + 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() - ! 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 @@ -297,29 +244,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 @@ -335,32 +277,26 @@ contains 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 + !> 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. 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 + 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 + integer :: i, j, k !< Generic loop iterators - 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 @@ -368,44 +304,27 @@ 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 - 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 - + ! 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 - 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 @@ -413,30 +332,27 @@ 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 + !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus subroutine s_icpp_varcircle(patch_id, patch_id_fp, q_prim_vf) ! 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 + 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 ! Generic loop iterators - integer :: i, j, k + 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 @@ -444,26 +360,17 @@ 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) + 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 - - 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,39 +380,36 @@ 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 + !> 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 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 ! Generic loop iterators - integer :: i, j, k + 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 @@ -515,29 +419,20 @@ 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 - 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,10 +442,9 @@ 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 @@ -558,30 +452,25 @@ contains 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 + !> 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 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 + 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 + real(wp) :: a, b - 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) @@ -589,36 +478,21 @@ 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 - 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 @@ -634,32 +508,28 @@ contains 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 + !> 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 subroutine s_icpp_ellipsoid(patch_id, patch_id_fp, q_prim_vf) ! 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 + 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 ! Generic loop iterators - integer :: i, j, k + 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 @@ -669,20 +539,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. + ! 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 - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -691,24 +554,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 @@ -725,29 +579,23 @@ contains 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 + !> 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. 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 + 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 + 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() @@ -761,34 +609,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 - ! 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. + ! 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) .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 +633,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 @@ -813,28 +649,23 @@ contains 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 + !> 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. 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 + 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 + real(wp) :: a, b, c - integer :: i, j, k !< Generic loop operators - real(wp) :: a, b, c @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -849,32 +680,19 @@ 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 - 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,33 +702,28 @@ 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. - !! @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 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. 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 + 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 + 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() @@ -924,37 +737,24 @@ 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. + ! 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) .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,9 +767,9 @@ 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 @@ -977,20 +777,18 @@ 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. + + ! Description: This patch assigns the primitive variables as analytical functions such that the code can be verified. ! 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 + 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 @@ -998,6 +796,7 @@ contains integer :: i, j, k ! Placeholders for the cell boundary values real(wp) :: pi_inf, gamma, lit_gamma + @:HardcodedDimensionsExtrusion() @:Hardcoded1DVariables() @@ -1009,55 +808,45 @@ 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. + ! 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 - - 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 - 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 - 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 +864,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,27 +879,29 @@ 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 - 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 - 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,44 +941,40 @@ 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. - !! @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 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. 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 + 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 ! Generic loop iterators - integer :: i, j, k + 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 @@ -1195,19 +982,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 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 - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1216,27 +997,20 @@ 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 @@ -1245,28 +1019,22 @@ contains 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 + !> 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. 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 + 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 - integer :: i, j, k !< Generic loop iterators @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1278,8 +1046,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 @@ -1287,20 +1054,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. + ! 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 - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1308,17 +1068,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,7 +1080,6 @@ 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 @@ -1337,34 +1089,28 @@ contains 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 + !> 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. 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 + 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 + real(wp) :: radius - 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 @@ -1375,8 +1121,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 @@ -1384,19 +1129,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. + ! 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 - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1406,45 +1145,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 @@ -1461,28 +1184,23 @@ contains 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 + !> 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. 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 + 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 + real(wp) :: a, b, c, d - integer :: i, j, k !< Generic loop iterators - real(wp) :: a, b, c, d @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1499,19 +1217,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. + ! 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 - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1520,22 +1232,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,7 +1248,6 @@ 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 @@ -1554,43 +1256,35 @@ 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 + #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 ! 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 - 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) + print *, " * Reading model: " // trim(patch_icpp(patch_id)%model_filepath) end if model = f_model_read(patch_icpp(patch_id)%model_filepath) @@ -1634,57 +1328,49 @@ 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/) + 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) - 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) 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 *, "" @@ -1695,8 +1381,9 @@ 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]') real(wp), intent(in) :: cyl_y, cyl_z @@ -1706,45 +1393,42 @@ 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]') real(wp), dimension(1:3), intent(in) :: cyl - real(wp), dimension(1:3) :: cart + real(wp), dimension(1:3) :: cart - cart = (/cyl(1), & - cyl(2)*sin(cyl(3)), & - cyl(2)*cos(cyl(3))/) + 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. + !> 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]') - 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..0b5a6ba40a 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -5,104 +5,69 @@ !> @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 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. - 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 + ! 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 + !> @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 + integer :: i, j, k, l - ! Allocating the primitive and conservative variables allocate (q_prim_vf(1:sys_size)) 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 - ! Allocating the patch identities bookkeeping variable - 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 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 (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 - ! 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) + 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: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 @@ -112,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 @@ -123,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 @@ -141,38 +106,28 @@ 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. + !> 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 - ! 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) @@ -185,25 +140,22 @@ 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 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 + integer :: i - ! Dellocating the primitive and conservative variables do i = 1, sys_size deallocate (q_prim_vf(i)%sf) deallocate (q_cons_vf(i)%sf) @@ -216,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 69afc99041..e9545ce865 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -6,35 +6,25 @@ 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 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 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', & @@ -122,8 +112,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 @@ -176,7 +166,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 diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 2093ea30dd..f3096068c1 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -5,43 +5,37 @@ !> @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 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. + !> Allocate 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)) + 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. + !> 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 - integer :: i, j, k, l !< generic loop operators - real(wp) :: perturb_alpha + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + integer :: i, j, k, l + real(wp) :: perturb_alpha + real(wp) :: rand_real - real(wp) :: rand_real call random_seed() do k = 0, p @@ -51,15 +45,12 @@ 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 - - ! 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 @@ -67,16 +58,16 @@ 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 - integer :: i, j, k !< generic loop iterators + integer :: i, j, k + real(wp) :: perturb_alpha + real(wp) :: rand_real - 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 @@ -91,17 +82,17 @@ 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. + !> 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 call s_populate_variables_buffers(bc_type, q_prim_vf, pb%sf, mv%sf) @@ -109,19 +100,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 +119,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 @@ -155,16 +143,15 @@ 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 - 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 +176,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 +187,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 +213,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 @@ -243,20 +229,17 @@ 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 - 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 ! Compute prescribed energy spectra @@ -269,11 +252,9 @@ contains ! Main loop 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) + ! 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 Rij(2, 2) = 0.03_wp*uu0 Rij(3, 3) = 0.03_wp*uu0 @@ -293,8 +274,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 @@ -327,14 +307,15 @@ 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 - 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) @@ -352,10 +333,11 @@ 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 - real(wp) :: zeta, xi + + real(wp), intent(in) :: theta, eta + real(wp) :: zeta, xi real(wp), dimension(3) :: vec xi = 2._wp*pi*theta @@ -366,23 +348,24 @@ 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 - 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. + !> Compute 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 @@ -390,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 5dacdda7b6..fb5ebcf226 100644 --- a/src/pre_process/m_simplex_noise.fpp +++ b/src/pre_process/m_simplex_noise.fpp @@ -6,85 +6,60 @@ 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]. + !> 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 - 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 +117,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 +125,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 +133,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 +141,24 @@ 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]. + !> 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 - 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) @@ -240,14 +215,15 @@ 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 + 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..a3a7c51270 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -7,171 +7,101 @@ !> @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 - 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 - 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. + !> 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 - 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 !< - !! 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 + 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() 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 - - logical :: file_check !< - !! Generic logical used for the purpose of asserting whether a file - !! is or is not present in the designated location - - 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 - 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 + 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, & + & 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 + 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') + 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) 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 @@ -180,360 +110,237 @@ 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 + character(LEN=len_trim(case_dir)) :: file_loc + logical :: dir_check - 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)//'/.' + 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() call s_check_inputs() - ! Check all the patch properties 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 + logical :: dir_check + logical :: file_check - ! 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 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 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' + 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 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' + 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 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 - 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') + 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. - !! @param q_cons_vf_in Conservative variables + !> 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. 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 - - 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 + 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 + logical :: file_check + integer :: i, r - 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 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 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 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' + 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 - ! 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') + 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,23 +349,18 @@ 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 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' + 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,23 +369,18 @@ 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 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' + 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,62 +389,47 @@ 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 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 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. - !! @param q_cons_vf_in Conservative variables + !> 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. 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 + logical :: file_exist + integer :: i - integer :: i - - ! Open the file to read if (cfl_adap_dt) then write (file_loc, '(I0,A)') n_start, '.dat' 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 @@ -655,7 +437,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 @@ -667,17 +448,14 @@ 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) ! 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,31 +465,26 @@ 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. + !> Initialize all pre-process modules, allocate data structures, and set 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() @@ -726,11 +499,9 @@ 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 if (parallel_io .neqv. .true.) then s_generate_grid => s_generate_serial_grid s_read_grid_data_files => s_read_serial_grid_data_files @@ -745,7 +516,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 @@ -764,24 +535,13 @@ 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 + 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 - ! 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) @@ -806,8 +566,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) @@ -816,14 +575,15 @@ 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. + !> 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 - 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() @@ -851,19 +611,14 @@ 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. + !> Initialize MPI, read and validate user inputs on rank 0, and decompose 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. - if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -872,23 +627,22 @@ 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. + !> Finalize all pre-process modules, deallocate resources, and shut 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() @@ -899,8 +653,8 @@ 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 end module m_start_up diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 9197eecf8f..e16ff68571 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 Set 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 - 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..41c897cfd3 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -4,70 +4,73 @@ #:include 'macros.fpp' -!> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers +!> @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 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 + 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 - !> This subroutine initializes the acoustic source module + !> Initialize 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)) + 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)) do i = 1, num_source do j = 1, 3 @@ -104,18 +107,15 @@ 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 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)) @@ -123,15 +123,11 @@ 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 - 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 @@ -139,28 +135,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), 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 - - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + 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 + + sim_time = mytime ! Accumulated time, correct under adaptive dt + + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -178,12 +171,11 @@ 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)) - 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 @@ -214,7 +206,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,29 +257,28 @@ 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) + 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 - - elseif (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 @@ -296,11 +289,13 @@ 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 - ! 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) + 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_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 +304,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 @@ -333,41 +327,35 @@ 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 - !! @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]') - 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 - 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 - if (pulse(ai) == 1) then ! Sine wave + ! 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 omega = 2._wp*pi*frequency_local @@ -376,17 +364,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 +382,24 @@ 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 + !> Pre-compute non-zero spatial source weights 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 @@ -428,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 @@ -446,11 +432,11 @@ 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 - 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 @@ -459,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 @@ -479,38 +465,30 @@ 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 - !! @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 - real(wp), dimension(3), intent(in) :: loc - real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - real(wp) :: sig, r(3) + 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) - 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,60 +502,53 @@ 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 + !> 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 - real(wp), intent(in) :: sig, r(3) - real(wp), intent(out) :: source - real(wp) :: dist + integer, intent(in) :: ai + real(wp), intent(in) :: sig, r(3) + real(wp), intent(out) :: source + real(wp) :: dist source = 0._wp - if (support(ai) == 1) then ! 1D + ! 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) - - 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 (support(ai) /= 3 .or. abs(r(3)) < 0.25_wp*height(ai)) then ! additional height constraint for 3D + 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 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 - !! @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 - 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 + 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 - 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))) @@ -586,8 +557,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,41 +570,35 @@ 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 - !! @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 - 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, 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 - 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) @@ -647,11 +611,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 - - 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) @@ -665,9 +628,9 @@ 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 - C = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step + ! 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) z3 = C*r(3) @@ -682,48 +645,43 @@ 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 - !! @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]') - 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) else 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 - !! @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]') - 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 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 1b9b1a209b..7200390c2c 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -7,62 +7,46 @@ !> @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 -! $: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 + !> Initialize the body forces module 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 + @:ALLOCATE(rhoM(-buff_size:buff_size + m, -buff_size:buff_size + n, -buff_size:buff_size + p)) 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 + !> Compute 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 @@ -70,22 +54,19 @@ 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 - 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 @@ -94,23 +75,18 @@ 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 - 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 @@ -122,58 +98,51 @@ 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) + $: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 $: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) + $: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 $: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) + $: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. + !> 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 0f17bd60c3..2ff5952827 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -4,50 +4,34 @@ #: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 - - 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) 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) + !> 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]') 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 @@ -79,16 +63,12 @@ contains 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 + !> Bubble wall pressure: stiffened gas with Laplace pressure and viscous stress 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) @@ -98,17 +78,13 @@ 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]') 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 @@ -118,17 +94,13 @@ 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]') 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) @@ -138,23 +110,15 @@ 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]') 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)) + ! 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 @@ -166,23 +130,14 @@ contains 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 + !> Enthalpy derivative for Gilmore bubble model, Gilmore (1952) 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,80 +147,49 @@ 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 - - ! 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 + f_Hdot = (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) - (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 + !> Rayleigh-Plesset bubble radial acceleration 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 ) + real(wp) :: f_rddot_RP 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 + !> Compute the Gilmore bubble radial acceleration 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 + !> Keller-Miksis bubble wall 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 @@ -275,26 +199,17 @@ contains 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 + !> Keller-Miksis bubble radial acceleration 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,9 +218,7 @@ 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)) @@ -315,57 +228,45 @@ 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]') - 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) + !> 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]') - 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 @@ -396,97 +297,62 @@ 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]') - 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) + 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), 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 - - call s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, fCson, h0) + 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 + !> 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 + + 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 +366,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 +389,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 @@ -545,15 +401,10 @@ 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 - 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 - + ! 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 t_new = t_new + h @@ -583,53 +434,29 @@ 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 - - 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) + !> 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) + 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 + ! 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) + 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,16 +470,12 @@ 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) - ! 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 @@ -663,49 +486,20 @@ 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) - $: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. + 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 +510,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 +525,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 +540,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,51 +555,37 @@ 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. + 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) diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index dad03d3f87..b2c5f1fd97 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -7,31 +7,27 @@ !> @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 - 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) + 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. + !> Initialize the Euler-Euler bubble module impure subroutine s_initialize_bubbles_EE_module integer :: l @@ -69,14 +65,14 @@ 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 - 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 @@ -93,101 +89,81 @@ 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 + !> Compute the right-hand side for Euler-Euler bubble transport 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 + !> 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 - 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) + 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 - 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) :: 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 +182,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 +220,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,8 +243,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) @@ -302,22 +276,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 +300,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) @@ -352,6 +320,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 4ae590a4b8..437dbe0db2 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -7,96 +7,84 @@ !> @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 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 - 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 + ! (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 - + 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 + 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 ! Allocate space for the Eulerian fields needed to map the effect of the bubbles 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 +96,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 @@ -150,21 +136,18 @@ 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 - - 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 id = 0 @@ -193,9 +176,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) @@ -211,19 +194,17 @@ 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) $: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 +212,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_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 + !> 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 - 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 @@ -268,45 +245,45 @@ 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, 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, 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) @@ -318,13 +295,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)) @@ -352,49 +329,43 @@ 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 - + 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 + 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 - 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 +383,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 +414,19 @@ 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_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) @@ -470,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) @@ -485,23 +450,21 @@ 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) - 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) @@ -520,20 +483,18 @@ 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 + !> Contains the bubble dynamics subroutines. 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 + 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 - 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 @@ -541,10 +502,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") @@ -552,7 +511,7 @@ contains ! 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) @@ -563,8 +522,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 @@ -574,9 +533,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 +561,38 @@ 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 @@ -654,35 +605,27 @@ 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 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 +633,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 +650,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,43 +680,33 @@ 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 - !! @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) - 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 + $:GPU_ROUTINE(function_name='s_compute_cson_from_pinf', parallelism='[seq]', cray_inline=True) - real(wp) :: E, H + 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 #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel #:else @@ -796,14 +725,14 @@ 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 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,18 +744,16 @@ 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 @@ -836,38 +763,29 @@ 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) - integer, intent(in) :: bub_id, ptype + $:GPU_ROUTINE(function_name='s_get_pinf',parallelism='[seq]', cray_inline=True) + + 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 - - scoord = mtn_s(bub_id, 1:3, 2) + 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 - !< Find current bubble cell + !> Find current bubble cell cell(:) = int(scoord(:)) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -875,9 +793,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 @@ -888,7 +805,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 @@ -926,13 +843,13 @@ contains psi(3) = 0._wp end if - !< Perform bilinear interpolation - if (p == 0) then !2D + !> 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)) 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 +860,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) @@ -971,7 +887,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 @@ -988,7 +904,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 @@ -999,7 +916,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 @@ -1009,14 +926,13 @@ 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)) + 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,52 +940,46 @@ 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. - !! @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 + integer :: k - 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} + ! 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 @@ -1080,32 +990,30 @@ 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) - 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 $: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 - 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 @@ -1116,46 +1024,47 @@ 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) - 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 $: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 - 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 $: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 +1075,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 + !> Locate the cell index for a given physical position 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 @@ -1213,13 +1116,11 @@ 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 + ! 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 @@ -1231,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 @@ -1242,41 +1143,41 @@ 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() 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 + 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)) + ! 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)) 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 @@ -1303,76 +1204,64 @@ 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 + 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 - !! @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 - 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. - $: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 @@ -1381,20 +1270,17 @@ 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 - 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 +1290,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 +1305,41 @@ 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 + !> Write void fraction statistics at each time step 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, ', & - ! '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' + open (12, FILE=trim(file_loc), form='formatted', position='rewind') 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 @@ -1498,48 +1365,43 @@ 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 + 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 + !> 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 - 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(:) - 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 @@ -1553,11 +1415,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 +1428,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 +1441,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) @@ -1598,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) @@ -1622,37 +1480,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 +1512,17 @@ 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. + !> Compute 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)) @@ -1683,18 +1533,17 @@ 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 + 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,19 @@ 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 + !> Remove a specific Lagrangian bubble when dt becomes too small 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 @@ -1744,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 @@ -1763,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 @@ -1773,7 +1614,7 @@ contains end do @:DEALLOCATE(q_beta) - !Deallocating space + ! Deallocating space @:DEALLOCATE(lag_id) @:DEALLOCATE(bub_R0) @:DEALLOCATE(Rmax_stats) diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 784abc5adb..f1f80980b0 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -7,58 +7,47 @@ !> @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 - !> 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 - 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) - 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. + !> 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 - - $:GPU_PARALLEL_LOOP(private='[l,s_coord,cell]') + 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 @@ -71,18 +60,17 @@ 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') @@ -93,40 +81,37 @@ 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 - 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) + 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 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 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) @@ -134,7 +119,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 +128,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,28 +152,24 @@ 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 @@ -199,30 +179,29 @@ 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) + + $: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) 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))) @@ -239,12 +218,11 @@ 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 - - !< 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))) @@ -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). - !! @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) + + $: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. @@ -299,15 +275,13 @@ 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) + + $: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 +291,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 +300,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 @@ -338,25 +312,21 @@ 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) - integer, dimension(3), intent(in) :: cell - real(wp), intent(in) :: volpart - real(wp), intent(out) :: stddsv + $:GPU_ROUTINE(function_name='s_compute_stddsv',parallelism='[seq]', cray_inline=True) - real(wp) :: chardist, charvol - real(wp) :: rad + integer, dimension(3), intent(in) :: cell + real(wp), intent(in) :: volpart + real(wp), intent(out) :: stddsv + 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 @@ -367,7 +337,7 @@ 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) @@ -377,16 +347,12 @@ 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) - integer, intent(in) :: cellx, celly, cellz + $:GPU_ROUTINE(function_name='s_get_char_vol',parallelism='[seq]', cray_inline=True) + + integer, intent(in) :: cellx, celly, cellz real(wp), intent(out) :: Charvol if (p > 0) then @@ -401,17 +367,14 @@ 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) + + $: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 diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index f5f9cb4c30..0e36c48fbf 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -8,110 +8,90 @@ 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, & - 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 #:endif + implicit none 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. - - 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]') + ! 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. - !! 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(:,:,:,:) :: 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(:, :, :, :) :: 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]') + ! Cell-average fluxes (src - source). These are directly determined from the cell-average primitive variables, q_prims_rs_vf, + ! and not a Riemann solver. - !! 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(:,:,:,:) :: 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(:, :, :, :) :: 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]') + ! 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(:) :: ds !< Cell-width distribution in the s-direction + 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-direction + ! Bug with NVHPC when using nullified pointers in a declare create real(wp), pointer, dimension(:, :) :: fd_coef => null() - !! 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(:,:,:) :: 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]') - ! Bug with NVHPC when using nullified pointers in a declare create - ! real(wp), pointer, dimension(:, :) :: fd_coef => null() + ! 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. - 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 - $:GPU_DECLARE(create='[is1,is2,is3]') + type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions + $: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 + ! 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. + !> Initialize the CBC 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 +107,6 @@ contains if (n == 0) then is2%beg = 0 - else is2%beg = -buff_size end if @@ -136,41 +115,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 +143,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 +172,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 +206,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 +214,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 +222,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 +230,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 +243,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 +251,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 +259,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 +273,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 +281,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,16 +289,13 @@ 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]') + $: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 @@ -434,17 +345,14 @@ 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 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 @@ -456,6 +364,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 @@ -469,15 +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 - elseif (weno_order == 3) then - - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp + 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 fd_coef_${XYZ}$ (2, cbc_loc_in) = fd_coef_${XYZ}$ (0, cbc_loc_in)/3._wp @@ -486,49 +393,36 @@ 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) & - - 3._wp*ds(4)) + 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}$ (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 @@ -539,23 +433,15 @@ 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 - - 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 + if (cbc_dir_in == 1) then + ! 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 +454,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 @@ -584,8 +469,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,90 +480,64 @@ 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 + !> 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 + 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 - - ! Reshaping of inputted data and association of the FD and PI - ! coefficients, or CBC coefficients, respectively, hinging on + 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 ! selected CBC coordinate direction cbc_dir = cbc_dir_norm @@ -687,43 +545,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 +581,51 @@ 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 +716,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 +747,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 +772,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 +844,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 +874,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 +921,23 @@ 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() @@ -1123,37 +946,19 @@ 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 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 + end subroutine s_cbc - integer :: i, j, k, r !< Generic loop iterators + !> 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 + 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 @@ -1163,7 +968,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 +977,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 +1054,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 @@ -1341,156 +1129,134 @@ 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 + ! 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 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) $:GPU_UPDATE(device='[dj]') ! 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 +1265,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 @@ -1557,65 +1317,58 @@ 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. + !> Detect whether any domain boundary uses characteristic boundary conditions elemental subroutine s_any_cbc_boundaries(toggle) logical, intent(inout) :: toggle @@ -1668,9 +1421,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 +1431,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,9 +1442,8 @@ 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) diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 5543cba645..478f778c84 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -8,13 +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 @@ -22,8 +19,7 @@ module m_checker 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 @@ -46,51 +42,66 @@ contains !> 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 + + 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. + !> 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 + + 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 + !> Validate NVIDIA unified virtual memory configuration parameters 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 bb7c59ac5f..cbeac697af 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -6,24 +6,23 @@ !> @brief Characteristic boundary condition (CBC) computations for subsonic inflow, outflow, and slip walls 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 @@ -31,10 +30,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 @@ -48,16 +49,18 @@ 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]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -70,16 +73,18 @@ 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]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -92,16 +97,18 @@ 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]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -114,7 +121,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 @@ -122,12 +129,13 @@ 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) + + $: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 +149,18 @@ 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 +169,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))) @@ -186,12 +194,13 @@ 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 @@ -209,12 +218,13 @@ 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) + + $: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 +233,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 @@ -242,12 +252,13 @@ 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) + + $: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 +272,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 @@ -272,12 +283,13 @@ 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) + + $: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 +303,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 @@ -302,12 +314,13 @@ 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) + + $: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 @@ -315,12 +328,13 @@ 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) + + $: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 +343,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 @@ -348,5 +362,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 0663ae73ca..da1dcd9109 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -7,17 +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 @@ -25,77 +20,69 @@ 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 - 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]') + 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 - 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. + !> 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]') 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) j = gp%loc(2) @@ -116,36 +103,32 @@ 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]') 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) j = gp%loc(2) 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 - 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) @@ -194,30 +177,25 @@ 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 - !> @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]') 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) j = gp%loc(2) @@ -227,16 +205,16 @@ 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 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 @@ -302,26 +280,22 @@ contains 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) j = gp%loc(2) @@ -330,8 +304,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 @@ -374,25 +348,21 @@ 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]') 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) j = gp%loc(2) @@ -401,8 +371,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,39 +381,38 @@ 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 = 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 + 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. + !> 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]') 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) j = gp%loc(2) @@ -457,8 +426,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 @@ -467,8 +436,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 @@ -477,8 +446,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 @@ -517,18 +485,15 @@ 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]') 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) j = gp%loc(2) @@ -556,22 +521,20 @@ 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]') 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 +549,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) @@ -606,16 +569,14 @@ 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) - 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 @@ -635,18 +596,16 @@ 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]') 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 +617,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,9 +649,7 @@ 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 diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index f0178b44c6..086a218289 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -8,72 +8,48 @@ !> @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 - use m_boundary_common 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]') - - 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]') + 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]') !> @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 @@ -81,33 +57,14 @@ 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 - - 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) @@ -117,194 +74,136 @@ 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 - - character(LEN=path_len + name_len) :: file_path !< - !! Relative path to a file in the case directory + 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=8) :: file_date !< - !! Creation date of the run-time information file + file_path = trim(case_dir) // '/' // trim(file_name) - ! Opening the run-time information file - file_path = trim(case_dir)//'/'//trim(file_name) + open (3, FILE=trim(file_path), form='formatted', STATUS='replace') - 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, '(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 + 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 + !> 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 - 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' - 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') + file_path = trim(case_dir) // trim(file_path) + 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 + !> 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 - - 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 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 + !> 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 - 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 + !> 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 - integer, intent(in) :: t_step + 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 - integer :: j, k, l + 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 - $: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,21 +216,16 @@ 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 $: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]') 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) @@ -352,21 +246,15 @@ 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) + 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 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 @@ -374,22 +262,18 @@ 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 + 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 + 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 +281,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 @@ -408,14 +292,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 @@ -423,115 +300,77 @@ 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 - - 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 - + 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 - 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' + write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', t_step - ! 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)//'/.' + 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) + 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' + 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) + write (2) beta%sf(0:m,0:n,0:p); close (2) end if 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) + write (2) pb_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) 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' - 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) + write (2) mv_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) end do end do end if @@ -539,13 +378,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) @@ -559,9 +391,8 @@ 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)//'/.' + 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 +401,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 +409,10 @@ 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 - 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 +428,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 +440,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 +452,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 @@ -640,10 +471,9 @@ 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' + 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 +485,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 +499,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 +513,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 +529,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) @@ -725,10 +555,9 @@ 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' + 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 +572,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 +589,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 +605,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 +623,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) @@ -821,47 +648,34 @@ 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 - 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 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) + 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,10 +685,8 @@ contains end if 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 @@ -886,7 +698,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)) @@ -896,34 +708,28 @@ 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) + 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 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) @@ -933,65 +739,54 @@ 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) + 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) - 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 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) + 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) + 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 - ! Initialize MPI data I/O - 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) - ! 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) @@ -1001,123 +796,87 @@ 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) + 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) - 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 sys_size is correct 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 - ! 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) - 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 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 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 + 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) + 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. + !> Write 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]') - ! 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) @@ -1126,25 +885,21 @@ 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. + !> Dispatch immersed boundary data output to the serial or parallel writer subroutine s_write_ib_data_file(time_step) integer, intent(in) :: time_step @@ -1157,37 +912,26 @@ 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 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 + !> 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 + 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 nondim_time = real(t_step + t_step_old, wp)*dt else @@ -1195,97 +939,71 @@ contains end if 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) + 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 - elseif (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) + 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 - 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) + 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 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 + !> 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 + 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 - - ! 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), 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), 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 !< - !! 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) :: 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 + real(wp) :: rad, thickness !< For integral quantities + logical :: trigger !< For integral quantities + real(wp) :: rhoYks(1:num_species) T = dflt_T_guess - ! Non-dimensional time calculation if (time_stepper == 23) then nondim_time = mytime else @@ -1297,7 +1015,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 @@ -1324,16 +1041,14 @@ 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 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 @@ -1345,12 +1060,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 +1077,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 +1139,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 if (chemistry) then do d = 1, num_species rhoYks(d) = q_cons_vf(chemxb + d - 1)%sf(j - 2, k - 2, l) @@ -1455,14 +1163,13 @@ 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 - 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 +1182,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,12 +1221,11 @@ 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 + 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 @@ -1545,14 +1244,13 @@ 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, 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 +1269,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,134 +1328,53 @@ 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) - ! ptilde, & - ! ptot + 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 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 @@ -1781,18 +1393,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 +1412,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 +1433,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 +1456,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,8 +1485,7 @@ 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 @@ -1898,16 +1494,11 @@ 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 + 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)') '' @@ -1927,7 +1518,8 @@ 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) end do @@ -1937,7 +1529,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) @@ -1945,20 +1537,18 @@ contains end subroutine s_close_probe_files + !> Close the immersed boundary state file 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. + !> Initialize the data output 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 @@ -1983,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 @@ -1999,7 +1589,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_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 53a8396cbf..d0be1a8426 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -2,65 +2,52 @@ !! @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 - - 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 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 - ! 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 @@ -94,18 +81,15 @@ 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 @@ -113,49 +97,32 @@ 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 + 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 @@ -175,72 +142,52 @@ 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 - subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & - q_prim_vf2, q_prim_vf3, q_sf) - - integer, intent(in) :: i + !> 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 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 +195,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 +227,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 +255,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 +289,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 @@ -414,31 +336,26 @@ 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 - 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 + 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 $: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 +371,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 +396,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 +428,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 +445,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 +466,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) @@ -600,8 +516,8 @@ 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) diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 661767e13c..38005f76ca 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -6,14 +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_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use, intrinsic :: iso_c_binding + use m_derived_types + use m_global_parameters + use m_mpi_proxy #if defined(MFC_GPU) && defined(__PGI) use cufft #elif defined(MFC_GPU) @@ -24,59 +22,48 @@ 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 - - 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 - + 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 #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. + !> Initialize the FFTW module 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 ! Size of output array coming out of DFT cmplx_size = (p + 1)/2 + 1 @@ -86,14 +73,13 @@ 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; + 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,32 +101,30 @@ 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. - !! @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 - 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 #if defined(MFC_GPU) - $:GPU_PARALLEL_LOOP(collapse=3) do k = 1, sys_size do j = 0, m @@ -176,7 +160,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 +180,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 +189,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 +225,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,25 +245,25 @@ 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 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 @@ -287,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 @@ -300,16 +286,14 @@ 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) - 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) - ierr = cufftDestroy(fwd_plan_gpu) ierr = cufftDestroy(bwd_plan_gpu) #else @@ -326,4 +310,5 @@ contains #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..079d36ebc2 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -9,13 +9,11 @@ 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 + use m_helper_basic ! $:USE_GPU_MODULE() implicit none @@ -24,14 +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 @@ -50,147 +46,138 @@ 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 !> @{ - 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 + ! 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 !> @} - 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]') + 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 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 - + 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 :: 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 + 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 #: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 - ! 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_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) !> @} - 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 - !< amplitude, frequency, and phase shift sinusoid in each direction + 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 + !> 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}$ @@ -203,24 +190,23 @@ 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]') - - 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='[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='[relax, relax_model, palpha_eps,ptgalpha_eps]') + 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 logical :: bc_io @@ -239,230 +225,188 @@ 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 - - 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 + 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 + 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. - 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]') - $: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". + ! 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]') - !> @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 - ! 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 !> @} $: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]') - - 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. + $:GPU_DECLARE(create='[dir_idx, dir_flg, dir_idx_tau]') + 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 - 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]) - - $:GPU_DECLARE(create='[shear_num,shear_indices,shear_BC_flip_num,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 - 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. - + 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 - - 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. - $: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 + 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 + 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 - - 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. - - $:GPU_DECLARE(create='[ib,num_ibs,patch_ib,Np,airfoil_grid_u,airfoil_grid_l]') + logical :: ib + integer :: num_ibs + logical :: ib_state_wrt + 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 + + $:GPU_DECLARE(create='[ib, num_ibs, patch_ib, Np, airfoil_grid_u, airfoil_grid_l]') !> @} !> @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 - $: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 - $: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 - $: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]') - - real(wp), allocatable, dimension(:, :, :) :: ptil !< Pressure modification - - real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF + 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 + $: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 + $: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]') + + 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 - $:GPU_DECLARE(create='[qbmm, nmomsp,nmomtot,pi_fac]') + 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 $: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]') !> @} type(chemistry_parameters) :: chem_params @@ -471,36 +415,33 @@ 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 - $: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]') + 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]') !> @} !> @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]') + $: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,63 +452,58 @@ 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 - type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters - $:GPU_DECLARE(create='[bubbles_lagrange,lag_params]') + 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 - logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false - + 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 - 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]') + 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 - !> 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 - + integer :: i, j !< Generic loop iterator ! Logistics + case_dir = '.' run_time_info = .false. t_step_old = dflt_int @@ -596,7 +532,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 @@ -702,8 +638,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 @@ -761,7 +697,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 @@ -901,9 +837,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 @@ -911,6 +845,7 @@ contains #: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 @@ -918,30 +853,24 @@ 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 - ! 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 ! 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 @@ -955,10 +884,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 @@ -967,17 +894,12 @@ 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 - adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 + ! 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 - ! 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 @@ -993,7 +915,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 +949,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 @@ -1050,13 +971,12 @@ 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 - else if (model_eqns == 3) then cont_idx%beg = 1 cont_idx%end = num_fluids @@ -1069,15 +989,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 - 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 @@ -1110,8 +1029,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 @@ -1122,12 +1040,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 + ! 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 +1060,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 @@ -1165,20 +1079,18 @@ 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/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + 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]') + $:GPU_UPDATE(device='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') end if if (hyperelasticity) then @@ -1206,7 +1118,6 @@ contains psi_idx = sys_size + 1 sys_size = psi_idx end if - end if ! END: Volume Fraction Model @@ -1220,7 +1131,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 @@ -1230,27 +1141,23 @@ 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 - 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)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() 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]') @@ -1259,14 +1166,14 @@ 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 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 @@ -1274,28 +1181,22 @@ 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 + 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 + else ! Fully 3D cylindrical grid grid_geometry = 3 end if @@ -1316,44 +1217,39 @@ 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='[b_size,xibeg,xiend,tensor_size]') + $: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='[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='[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='[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 +1259,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,7 +1267,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)) @@ -1385,7 +1281,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 @@ -1403,7 +1299,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) @@ -1411,13 +1306,10 @@ 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 @@ -1427,9 +1319,9 @@ contains 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 @@ -1457,10 +1349,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 e687244280..22c2aace73 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -8,42 +8,33 @@ 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 - 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 !< + ! 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 + !> Initialize the hyperelastic module 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 @@ -67,34 +58,25 @@ 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. - !! @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 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + #:if USING_AMD real(wp), dimension(10) :: tensora, tensorb #:else @@ -107,34 +89,30 @@ 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) then $:GPU_LOOP(parallelism='[seq]') 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 @@ -162,13 +140,11 @@ 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 - ! 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) @@ -193,17 +169,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 @@ -211,102 +186,72 @@ 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 + !> 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]') 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) - ! 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 - ! 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) + 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) + ! 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 - !> 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]') 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 - ! tensor is the symmetric tensor & calculate the trace of the tensor + 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 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) - ! 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 - ! 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) + 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) + ! 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 - !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. + !> Finalize the hyperelastic module impure subroutine s_finalize_hyperelastic_module() - integer :: i !< iterator - + integer :: i !< iterator ! Deallocating memory + do i = 1, b_size @:DEALLOCATE(btensor%vf(i)%sf) end do diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 8ee46b1ba8..d38741934e 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -7,37 +7,35 @@ !> @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 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(:,:,:) :: 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(:,:,:) :: 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]') + 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. + !> Initialize the hypoelastic module impure subroutine s_initialize_hypoelastic_module integer :: i @@ -67,43 +65,33 @@ 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 + !> Compute the hypoelastic stress source terms 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 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 @@ -121,10 +109,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 +133,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 +146,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 +163,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,16 +187,17 @@ 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] 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 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 +211,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,42 +297,38 @@ 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. + !> Finalize the hypoelastic module impure subroutine s_finalize_hypoelastic_module() @:DEALLOCATE(Gs_hypo) @@ -394,42 +346,41 @@ 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 + 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 +393,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) + 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 phi = acos(argument) diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index d725a3e5f3..a7d8e45eee 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -12,63 +12,55 @@ !> @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_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 - use m_mpi_common 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 - !! 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 !< + 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 + 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. + !> 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 - - 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 + if (p > 0) then !> IB Patches !> @{ call s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) @@ -78,13 +70,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 +86,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,45 +95,36 @@ 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. - !! @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 - 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 - ! 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 @@ -158,18 +140,12 @@ 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) + $: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 @@ -178,24 +154,20 @@ 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 + 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 +175,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) @@ -215,7 +187,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 @@ -223,7 +195,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 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) xa = xc/ca_in @@ -257,7 +230,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 +238,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,13 +253,13 @@ 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 - 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 @@ -306,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 @@ -323,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 @@ -342,23 +309,18 @@ 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 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, 1:3) :: inverse_rotation + 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 +330,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 +342,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 +385,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 +393,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 +411,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 = 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 = [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,13 +430,12 @@ 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 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 @@ -487,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 @@ -508,36 +465,26 @@ 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 + 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) @@ -547,30 +494,23 @@ 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) - ! 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) + ! 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 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 @@ -578,32 +518,23 @@ 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 + 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 - !! 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) @@ -623,16 +554,12 @@ 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. - $:GPU_PARALLEL_LOOP(private='[i,j,k,cart_y,cart_z]',& - & copyin='[encoded_patch_id,center,radius]', collapse=3) + ! 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 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 @@ -640,9 +567,7 @@ 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 @@ -652,36 +577,27 @@ 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 + 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) 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) 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) @@ -693,21 +609,19 @@ 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) - ! 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) + ! 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) 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)) @@ -715,16 +629,12 @@ 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 - - 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 + 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 ! Updating the patch identities bookkeeping variable ib_markers%sf(i, j, k) = encoded_patch_id end if @@ -735,31 +645,21 @@ 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 + 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) 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) @@ -767,7 +667,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) @@ -778,48 +678,34 @@ 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) - ! 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) + ! 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) 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 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 - - 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 - + 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 ! Updating the patch identities bookkeeping variable ib_markers%sf(i, j, k) = encoded_patch_id end if @@ -830,26 +716,26 @@ 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 + 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) @@ -862,10 +748,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 - $:GPU_PARALLEL_LOOP(private='[i,j, xy_local]',& - & copyin='[encoded_patch_id,center,ellipse_coeffs,inverse_rotation,x_cc,y_cc]', collapse=2) + ! 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) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -884,31 +769,27 @@ 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 + 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 @@ -929,8 +810,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] @@ -945,16 +825,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 @@ -967,34 +846,30 @@ 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 + 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) @@ -1016,8 +891,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 @@ -1037,8 +911,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 +920,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 @@ -1059,53 +932,55 @@ 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 - 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. + !> Convert cylindrical (r, theta) coordinates to Cartesian (y, z) subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: cyl_y, cyl_z @@ -1115,25 +990,24 @@ 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]') real(wp), dimension(1:3), intent(in) :: cyl - real(wp), dimension(1:3) :: cart + real(wp), dimension(1:3) :: cart - cart = (/cyl(1), & - cyl(2)*sin(cyl(3)), & - cyl(2)*cos(cyl(3))/) + 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. + !> 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]') - real(wp), intent(IN) :: cyl_x, cyl_y + real(wp), intent(in) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) @@ -1141,11 +1015,10 @@ contains 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 @@ -1179,13 +1052,12 @@ 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 + 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 @@ -1198,15 +1070,14 @@ 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]') - 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 @@ -1225,20 +1096,22 @@ 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 + 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 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 @@ -1258,19 +1131,18 @@ 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]') 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..785bf2dec3 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -4,42 +4,27 @@ #: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 - - 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 - use m_viscous - use m_model 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]') @@ -47,9 +32,9 @@ 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]') + $:GPU_DECLARE(create='[gp_layers, num_gps]') #elif defined(MFC_OpenMP) $:GPU_DECLARE(create='[num_gps]') #endif @@ -57,15 +42,13 @@ module m_ibm 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)) @@ -76,8 +59,7 @@ contains 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 @@ -111,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 @@ -129,6 +111,7 @@ contains @:ALLOCATE(ghost_points(1:max_num_gps)) $:GPU_ENTER_DATA(copyin='[ghost_points]') + ! 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) @@ -139,60 +122,50 @@ 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 - - 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 + 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. - - 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 - type(ghost_point) :: innerp + ! 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) :: 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 +189,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 +206,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 +240,20 @@ 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)) + ! 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)) 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 +266,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,14 +280,16 @@ 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 - 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 @@ -324,8 +298,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 +336,6 @@ contains end if if (qbmm) then - nbub = nmom_IP(1) $:GPU_LOOP(parallelism='[seq]') do q = 1, nb*nmom @@ -390,8 +362,7 @@ 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 @@ -400,30 +371,28 @@ 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 - - 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 +414,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 +438,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 +454,12 @@ 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 @@ -510,21 +480,20 @@ 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 - - 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 @@ -556,22 +525,24 @@ 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 - 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 @@ -639,22 +610,21 @@ 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 - - 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]') + 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]') do q = 1, num_gps gp = ghost_points_in(q) ! Get the interpolation points @@ -663,7 +633,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 +642,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,16 +684,15 @@ 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 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 @@ -741,7 +707,6 @@ contains interp_coeffs = eta/buf end if end if - end if ghost_points_in(q)%interp_coeffs = interp_coeffs @@ -750,50 +715,28 @@ 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 - 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 + !> 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, & - 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 + & 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 #: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 +777,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,16 +818,14 @@ 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 @@ -901,17 +837,16 @@ contains 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 @@ -944,20 +879,18 @@ 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) - ! 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 +912,10 @@ 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 +923,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 +957,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,15 +1022,16 @@ 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 + !> Finalize the IBM module impure subroutine s_finalize_ibm_module() @:DEALLOCATE(ib_markers%sf) @@ -1094,17 +1046,14 @@ contains !> 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 +1082,31 @@ 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 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 + 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 if (p == 0) then normal_axis = [0, 0, 1] @@ -1170,42 +1119,47 @@ 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 - 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 + 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 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 - 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 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') @@ -1223,7 +1177,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 @@ -1236,10 +1190,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 @@ -1261,15 +1217,17 @@ 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]') - 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..7d0f18cb26 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -8,46 +8,37 @@ !> @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 - use m_helper - use m_boundary_common 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 +56,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 @@ -135,7 +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 @@ -151,15 +100,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)) + 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 ! create map @@ -167,47 +112,36 @@ 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 @: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 + 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 +161,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 +173,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)) @@ -273,18 +206,18 @@ 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 - !DIR$ OPTIMIZE (-haggress) + ! 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 @@ -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,39 +251,38 @@ 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) 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, 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 + 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 @@ -360,8 +292,8 @@ 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) + 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 do j = idwbuff(1)%beg, idwbuff(1)%end @@ -375,30 +307,25 @@ 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 - !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,17 +369,16 @@ 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 @@ -461,57 +387,54 @@ 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 - !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 +445,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 +466,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 +477,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 +499,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 +562,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -685,60 +602,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 +670,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 +814,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 +843,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 +868,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 +879,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 +901,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 +912,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 +935,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 +999,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -1150,88 +1040,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 +1136,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 +1303,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 +1333,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 +1347,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 +1358,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 +1432,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -1602,60 +1473,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 +1544,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 +1682,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 +1712,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 +1726,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 +1737,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 +1755,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 +1766,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 +1841,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -2030,88 +1882,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 +1981,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 +2177,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 +2191,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 +2202,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 +2216,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 +2226,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 +2306,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -2515,88 +2347,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,178 +2446,164 @@ 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 @@ -2795,18 +2613,16 @@ contains 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) + !> 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]') - 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 +2636,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,61 +2651,51 @@ 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. + !> 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 - - 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 @@ -2901,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 @@ -2911,7 +2715,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 @@ -2929,7 +2733,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 efe3d53cd2..a2b6c84326 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -9,55 +9,37 @@ 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 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 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 + 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]') 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 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 @@ -70,17 +52,14 @@ contains 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 - 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) @@ -201,7 +180,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 @@ -253,24 +233,25 @@ 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. + !> 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 + + 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 + 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. + !> 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 de1af10f24..5c9e844ec6 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -7,45 +7,37 @@ !> @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 use m_mpi_proxy - 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 + !> Allocate and initialize MUSCL reconstruction working arrays subroutine s_initialize_muscl_module() ! Initializing in x-direction @@ -53,7 +45,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 @@ -66,8 +58,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 @@ -83,8 +75,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 @@ -93,31 +85,29 @@ 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 + !> 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) + + 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 - 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 +128,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 +141,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,52 +160,47 @@ 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 + 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 - 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,44 +211,37 @@ 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) + !> 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, & - 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 + & 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) 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 @@ -282,10 +260,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,15 +271,13 @@ 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 @@ -311,24 +287,19 @@ 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 - integer, intent(in) :: muscl_dir + integer, intent(in) :: muscl_dir + integer :: j, k, l, q !< Generic loop iterators + ! Determine MUSCL-reconstructed variables and map coordinate directions - 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 v_size = ubound(v_vf, 1) $: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 +316,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 +332,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 @@ -376,7 +347,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) @@ -390,4 +361,5 @@ contains @: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..7786ce4afe 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -5,19 +5,19 @@ #: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 + use m_derived_types + use m_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 @@ -49,13 +49,12 @@ 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 - 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 @@ -69,10 +68,11 @@ contains !> 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) @@ -89,11 +89,12 @@ contains !> 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]') @@ -107,24 +108,23 @@ contains !> 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 @@ -137,30 +137,30 @@ contains !> 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 + ! Pressure relaxation convergence tolerance 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 +177,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 +187,11 @@ 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)) + ! 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) - 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 +200,27 @@ 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,16 +290,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 diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index d081b8f83e..e32fd92954 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -8,23 +8,18 @@ !> @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 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 +30,20 @@ module m_qbmm #:endif type(int_bounds_info) :: is1_qbmm, is2_qbmm, is3_qbmm - $:GPU_DECLARE(create='[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]') + 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. + !> Initialize 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,336 +54,330 @@ contains $:GPU_ENTER_DATA(copyin='[nterms]') $:GPU_UPDATE(device='[nterms]') - #:endif @: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 - 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 (.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 - - 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 + 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) = 2._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) = 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) = 3._wp + i2 - momrhs(3, i1, i2, 3, 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 + 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 - - 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 + 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) = 2._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) = 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) = 3._wp + i2 - momrhs(3, i1, i2, 3, 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 + 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 @@ -412,19 +400,21 @@ 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 - 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. + 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. - 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 +426,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 +446,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 +562,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 @@ -567,189 +586,191 @@ 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) + + $:GPU_ROUTINE(function_name='s_coeff_nonpoly',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) :: 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 - 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. + !> 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) + + $:GPU_ROUTINE(function_name='s_coeff',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) :: 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 - 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. + !> 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 + 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 - 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 - 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) @@ -773,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]') @@ -785,11 +806,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 +836,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 +877,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 +898,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 @@ -885,15 +930,15 @@ 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) + + $: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 @@ -901,22 +946,23 @@ 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. + !> Perform 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 + $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', cray_inline=True) + + 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(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) @@ -962,29 +1008,29 @@ 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) - real(wp), dimension(2), intent(inout) :: frho, fup - real(wp), dimension(3), intent(in) :: fmom + $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', cray_inline=True) - real(wp) :: bu, d2, c2 + real(wp), dimension(2), intent(inout) :: frho, fup + 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. + !> 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]') #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(4, 3), intent(in) :: abscX, abscY, wght_in @@ -992,9 +1038,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]') @@ -1009,8 +1054,9 @@ 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]') #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(4), intent(in) :: abscX, abscY, wght_in @@ -1018,15 +1064,15 @@ 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]') 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 diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 6b8288a0b8..1f347a0289 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -5,150 +5,109 @@ #: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 - - 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 - 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 - 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 - !! 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 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 !> @} 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. - + 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, 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 + type(int_bounds_info) :: iv !< Vector field indical bounds $:GPU_DECLARE(create='[iv]') !> @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,24 +115,22 @@ 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. + !> Initialize the RHS 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]') @@ -183,26 +140,27 @@ 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 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)) + @: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 if (.not. igr) then @@ -211,7 +169,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]') @@ -227,87 +186,66 @@ 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 - ! 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)) @: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,14 +267,10 @@ 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)) @:ALLOCATE(dq_prim_dz_qp(1:1)) @@ -344,7 +278,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)) @@ -356,41 +289,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 @@ -416,17 +349,14 @@ 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 +364,27 @@ 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 +397,28 @@ 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 +427,35 @@ 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 - + 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)) @@ -566,9 +473,9 @@ 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) + $: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,8 +488,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)) @@ -590,20 +496,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 @@ -611,16 +513,14 @@ 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)) 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 @@ -631,25 +531,31 @@ contains 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) + !> 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, & - 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(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 + & 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(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 + 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") @@ -657,7 +563,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 +578,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 +589,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 +606,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 +624,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 @@ -744,13 +641,11 @@ 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 - $: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 +672,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,153 +681,92 @@ 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 - call nvtxEndRange ! WENO + call nvtxEndRange ! WENO ! 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 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 + ! 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) - - ! 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 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 @@ -942,20 +776,15 @@ 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, & - 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 - ! 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) @@ -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 @@ -1010,41 +833,29 @@ 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) + 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 +872,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 @@ -1087,7 +898,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 @@ -1095,23 +906,21 @@ 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 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 +929,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 @@ -1139,7 +948,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 +964,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 +975,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,8 +986,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 @@ -1185,7 +994,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 +1010,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 @@ -1211,13 +1021,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 +1035,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,8 +1051,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 @@ -1253,8 +1059,8 @@ 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 - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,inv_ds,velocity_val,flux_face1,flux_face2]') + 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 do q = 0, n @@ -1263,29 +1069,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]') + 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 do q = 0, n @@ -1302,7 +1106,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 @@ -1312,9 +1117,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,165 +1127,172 @@ 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 + !> 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) + 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 + 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 - 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) 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 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, 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]') + 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 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 - 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) 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 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, 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]') + 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 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,95 +1300,95 @@ 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 - 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) 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 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, 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]') + 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 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) + !> 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 - 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 - 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 (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 +1396,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 +1426,14 @@ 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 +1443,65 @@ 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 @@ -1728,21 +1511,17 @@ 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) + $: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,31 +1529,26 @@ 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 $:END_GPU_PARALLEL_LOOP() 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 +1556,14 @@ 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 +1571,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,19 +1602,15 @@ 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 @@ -1860,28 +1620,14 @@ 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 - subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir) + !> 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 - 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 :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] @@ -1891,12 +1637,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,38 +1649,31 @@ 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) + !> 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 - 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 :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l ! Reconstruction in s1-direction @@ -1946,25 +1683,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 +1711,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 +1724,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 @@ -2053,7 +1787,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 +1796,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 +1803,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) @@ -2174,4 +1905,3 @@ contains 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..72055ef4ab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -10,29 +10,17 @@ 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 + 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 +28,44 @@ 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 - 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 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]') !> @} - !> 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. + ! 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 - 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 +73,162 @@ 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 + 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) - - 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 + !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical + !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) + !! s_compute_cylindrical_viscous_source_flux + subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & + + & dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & + & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz if (grid_geometry == 3) then - call s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) + 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 + !> 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, & - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_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) - 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 + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L, flux_tau_R + 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 - 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_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 - type(riemann_states) :: Ga ! Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm ! Conservative momentum variables - - integer :: i, j, k, l, q !< Generic loop iterators - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - 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 @@ -391,14 +258,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) @@ -463,10 +330,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 +391,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 +417,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 @@ -587,8 +454,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) @@ -601,51 +467,19 @@ 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, 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) @@ -662,77 +496,68 @@ 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) - 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 + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L)) else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) else s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) end if if (hyper_cleaning) then - ! Dedner GLM: (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 - 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))))) + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(dir_idx(1)) - c_L*Ms_L s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + 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 + ! 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 @@ -743,22 +568,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 @@ -766,78 +586,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_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 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) 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 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) 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 +641,24 @@ 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 - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + else if (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + 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 +666,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 + ! 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, 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,43 +709,50 @@ 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 + ! 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 + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 - flux_rsx_vf(j, k, l, 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}$) - ! 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}$) + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y + ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ + ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) $:GPU_LOOP(parallelism='[seq]') do i = 0, 2 - flux_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 +760,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 +777,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 +786,129 @@ 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 + !> 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, & - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_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) - 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 + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L, flux_tau_R + 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 - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(3) :: vel_L, vel_R - real(wp), dimension(3) :: alpha_L, alpha_R - real(wp), dimension(10) :: Ys_L, Ys_R - real(wp), dimension(10) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp), dimension(3, 3) :: vel_grad_L, vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + 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_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)`. + !> Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: vel_grad_L, vel_grad_R #:endif - real(wp) :: rho_L, rho_R - - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi - real(wp) :: T_L, T_R - real(wp) :: Y_L, Y_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp) :: G_L, G_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp), dimension(3) :: xi_field_L, xi_field_R - - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_M, xi_P - - real(wp) :: ptilde_L, ptilde_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR - real(wp) :: alpha_L_sum, alpha_R_sum - real(wp) :: zcoef, pcorr !< low Mach number correction - - type(riemann_states) :: c_fast, pres_mag + real(wp) :: rho_L, rho_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi + real(wp) :: T_L, T_R + real(wp) :: Y_L, Y_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp), dimension(3) :: xi_field_L, xi_field_R + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_M, xi_P + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum + real(wp) :: zcoef, pcorr !< low Mach number correction + type(riemann_states) :: c_fast, pres_mag type(riemann_states_vec3) :: B - - type(riemann_states) :: Ga ! Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm ! Conservative momentum variables - - integer :: i, j, k, l, q !< Generic loop iterators - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, 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) + type(riemann_states) :: Ga !< Gamma (Lorentz factor) + type(riemann_states) :: vdotB, B2 + type(riemann_states_vec3) :: b4 !< 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm !< Conservative momentum variables + integer :: i, j, k, l, q !< Generic loop iterators + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions + + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, 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 @@ -1187,14 +938,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) @@ -1259,10 +1010,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 +1072,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 +1097,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 @@ -1380,8 +1131,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) @@ -1394,11 +1144,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 +1183,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 @@ -1456,78 +1201,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_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 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) 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 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) 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 +1256,24 @@ 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 - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + else if (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + 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 +1281,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 + ! 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, 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,34 +1324,35 @@ 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 + ! 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 + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 - flux_rsx_vf(j, k, l, 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}$) - ! 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}$) + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y + ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ + ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) $:GPU_LOOP(parallelism='[seq]') do i = 0, 2 - flux_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 +1360,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 +1377,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 +1391,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 +1451,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 +1460,244 @@ 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 - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + !> 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, & - 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 + & 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) - ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_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, & + & 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 + ! Intercell fluxes + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R @@ -1989,7 +1706,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 +1720,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 +1754,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 +1766,41 @@ 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 + 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 - 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 + ! 6-EQUATION MODEL WITH HLLC HLLC star-state flux with contact wave speed s_S 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]') + ! 6-equation model (model_eqns=3): separate phasic internal energies + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, vel_L, vel_R, Re_L, Re_R, alpha_L, alpha_R, Ys_L, & + & Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, & + & h_avg_2, tau_e_L, tau_e_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, zcoef, rho_L, & + & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, & + & T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & + & Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, G_L, G_R, & + & rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & + & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & + & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & + & xi_M, xi_P, xi_L, xi_R, xi_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 +1836,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 +1883,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) @@ -2212,14 +1922,14 @@ 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 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 +1953,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,77 +1979,70 @@ 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)))) + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & + & ))/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & + & ))/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & + & + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1)) & + & *(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R & + & - vel_R(dir_idx(1)))) else s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - + 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))))) + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(dir_idx(1)) - c_L*Ms_L s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + 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)) - 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 @@ -2348,44 +2051,42 @@ 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)) + 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) + ! 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 + ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star + (s_M/s_L)*(s_P/s_R)*pcorr*s_S ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then - flux_ene_e = 0._wp; + 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 +2094,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. + ! 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)) = & - 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 + ! 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,35 +2134,34 @@ 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 - ! REFERENCE MAP FLUX. + ! Hyperelastic reference map flux for material deformation tracking 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 +2171,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 +2186,29 @@ 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 + ! 4-equation model (model_eqns=4): single pressure, velocity equilibrium + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & + & nbub_L, nbub_R, rho_L, rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, & + & T_avg, eps, c_sum_Yi_Phi, T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, & + & Gamm_L, Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, & + & G_L, G_R, rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & + & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & + & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & + & xi_M, xi_P, xi_L, xi_R, xi_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,120 +2264,98 @@ 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))))) + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(dir_idx(1)) - c_L*Ms_L s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + 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)) + 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) + ! 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 + ! 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 - !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 +2364,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 +2381,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 +2401,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 +2415,18 @@ 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 + ! 5-equation model with Euler-Euler bubble dynamics + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, & + & vel_R, rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, Re_L, Re_R, pcorr, zcoef, rho_L, & + & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, & + & qv_R, qv_avg, c_L, c_R, c_avg, vel_L_rms, vel_R_rms, vel_avg_rms, vel_L_tmp, vel_R_tmp, & + & Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, alpha_R_sum, s_L, s_R, s_M, s_P, s_S, xi_M, & + & xi_P, xi_L, xi_R, xi_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 @@ -2804,7 +2486,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 @@ -2815,15 +2497,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 +2549,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 @@ -2891,7 +2572,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 @@ -2924,19 +2604,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,45 +2633,36 @@ 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))))) + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(dir_idx(1)) - c_L*Ms_L s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + 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)) @@ -3005,11 +2675,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 @@ -3017,8 +2685,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 @@ -3026,71 +2693,53 @@ 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 + ! 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 ! 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 + ! 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)) = & - 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 +2747,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 +2774,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 +2795,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 @@ -3175,12 +2810,18 @@ contains end do $: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]') + ! 5-equation model (model_eqns=2): mixture total energy, volume fraction advection + $:GPU_PARALLEL_LOOP(collapse=3, private='[Re_max, i, q, T_L, T_R, vel_L_rms, vel_R_rms, pres_L, pres_R, & + & rho_L, gamma_L, pi_inf_L, qv_L, rho_R, gamma_R, pi_inf_R, qv_R, alpha_L_sum, & + & alpha_R_sum, E_L, E_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & + & Gamm_R, Y_L, Y_R, H_L, H_R, qv_avg, rho_avg, gamma_avg, H_avg, c_L, c_R, c_avg, s_P, & + & s_M, xi_P, xi_M, xi_L, xi_R, 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 @@ -3205,23 +2846,26 @@ 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) + 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 +2894,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) @@ -3351,7 +2993,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 @@ -3383,16 +3025,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,57 +3053,53 @@ 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)))) + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & + & ))/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & + & ))/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & + & + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1)) & + & *(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R & + & - vel_R(dir_idx(1)))) else s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - + 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))))) + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(dir_idx(1)) - c_L*Ms_L s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + 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)) @@ -3472,49 +3110,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)) + 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) + ! 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 + ! 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 ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then @@ -3522,15 +3145,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 +3162,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. + ! Hyperelastic reference map flux for material deformation tracking 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 +3213,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 +3223,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 +3250,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,120 +3271,93 @@ 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 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 + !> 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, & - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_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) - 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 + 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 - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz ! Local variables: + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R #:else real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R #:endif type(riemann_states_vec3) :: vel - type(riemann_states) :: rho, pres, E, H_no_mag - type(riemann_states) :: gamma, pi_inf, qv - type(riemann_states) :: vel_rms - + type(riemann_states) :: 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 - ! 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 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) @@ -3802,16 +3383,18 @@ 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)] - 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)] + if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated + B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + 1)] + B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & B_idx%beg + 1)] + else ! 2D/3D: Bx, By, Bz as variables + B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), qL_prim_rs${XYZ}$_vf(j, k, & + & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + dir_idx(3) - 1)] B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + & 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 @@ -3834,13 +3417,16 @@ 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) + 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 +3437,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) @@ -3880,33 +3465,39 @@ 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 (Alfvén) 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) - ! (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 + ! Select HLLD flux region if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -3921,9 +3512,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) @@ -3938,10 +3528,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 @@ -3952,18 +3542,15 @@ 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. + !> 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 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)) @@ -3983,34 +3570,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 +3595,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 +3613,41 @@ 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 - type(int_bounds_info), intent(in) :: ix, iy, iz + !> 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, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) - integer :: i, j, k, l !< Generic loop iterator + 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 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 +3655,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 +3669,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 +3691,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 +3702,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 +3713,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 +3751,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 +3762,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 +3801,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 +3812,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 +3848,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 +3859,24 @@ 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 +3887,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 +3896,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 +3905,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 +3930,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 +3940,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 +3950,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 + !> Set up the chosen Riemann solver algorithm for the current direction + subroutine s_initialize_riemann_solver(flux_src_vf, norm_dir) - integer, intent(in) :: norm_dir - - integer :: i, j, k, l ! Generic loop iterators + 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 +4017,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 @@ -4601,7 +4064,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 @@ -4645,95 +4107,79 @@ 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). - !! @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 - 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 + !> 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) + + 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 - 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. - - $: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]') + 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]') do l = iz%beg, iz%end do k = iy%beg, iy%end do j = ix%beg, ix%end - ! Determine indices for the 'right' state for averaging across the interface idx_rp = [j, k, l] idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + ! 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))) + 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 @@ -4741,20 +4187,20 @@ 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) + 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) + 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) + vel_src_int = vel_src_rsz_vf(l, k, j,1:num_dims) r_eff = y_cc(k) end select @@ -4775,7 +4221,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 @@ -4787,44 +4233,48 @@ 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 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 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 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 @@ -4832,63 +4282,46 @@ 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). - 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) + !> 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) ! 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, 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. - - $: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]') + 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]') 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 +4329,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 +4379,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,15 +4392,13 @@ 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 @@ -4973,50 +4406,41 @@ 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]') ! 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 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 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. - !! @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]') ! Arguments @@ -5029,8 +4453,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 @@ -5039,33 +4462,21 @@ 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 - - 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 + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + integer :: i, j, k, l !< Generic loop iterators ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_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 +4489,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 +4501,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 +4513,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 +4539,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 +4551,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 +4563,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 +4587,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 +4599,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 diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index a7680f84e9..e20ec982fe 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -8,34 +8,28 @@ !> @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 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 - !! @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 - 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 @@ -44,63 +38,41 @@ 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 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 - !! @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) + + $: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 +80,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 +92,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 @@ -168,26 +138,16 @@ 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]') - 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 + $: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 ! Inviscid CFL calculation if (p > 0 .or. n > 0) then @@ -202,32 +162,24 @@ 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 @@ -236,24 +188,16 @@ 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]') - 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 + $: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 ! Inviscid CFL calculation if (p > 0 .or. n > 0) then @@ -267,20 +211,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 diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 4c670fc686..c3f38ef500 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -8,106 +8,60 @@ !> @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() 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 - 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) @@ -117,23 +71,16 @@ 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 - ! 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 + 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 - ! 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, & @@ -151,50 +98,31 @@ 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 - - ! Checking that an input file has been provided by the user. If it - ! has, then the input file is read in, otherwise, simulation exits. + #: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 + 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) @@ -203,7 +131,6 @@ contains bodyForces = .true. end if - ! Store m,n,p into global m,n,p m_glb = m n_glb = n p_glb = p @@ -212,35 +139,27 @@ 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. + !> Validate that all user-provided inputs form a consistent simulation configuration impure subroutine s_check_input_file - ! Relative path to the current directory file in the case directory character(LEN=path_len) :: file_path + logical :: file_exist - ! Logical used to check the existence of the current directory file - 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() @@ -248,38 +167,26 @@ 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 - - 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 + 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 + integer :: i, r - ! 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 @@ -288,19 +195,15 @@ 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' + 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 +212,52 @@ 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') - read (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) + 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,33 +266,25 @@ 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') - read (2) pb_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + 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') - read (2) mv_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + 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 @@ -413,44 +293,35 @@ 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 + 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 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)) 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,28 +340,25 @@ 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 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 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 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' + 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,19 +367,15 @@ 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 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' + 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,16 +384,12 @@ 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 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 @@ -541,13 +401,12 @@ 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 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 @@ -559,20 +418,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) @@ -581,21 +437,18 @@ 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 + 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 +456,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,37 +470,29 @@ 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 if (cfl_dt) then write (file_loc, '(I0,A)') n_start, '.dat' 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 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) @@ -658,53 +501,41 @@ 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 + 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 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_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 +545,24 @@ 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. - !! @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 - - 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 +571,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 +588,30 @@ 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. + !> 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 - real(wp), intent(inout) :: time_avg - integer :: i + integer, intent(inout) :: t_step + real(wp), intent(inout) :: time_avg + integer :: i if (cfl_dt) then if (cfl_const_dt .and. t_step == 0) call s_compute_dt() @@ -821,22 +641,13 @@ 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 + & 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 + & 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 @@ -861,16 +672,17 @@ contains 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) + !> 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) - 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 +703,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 +729,19 @@ 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. + !> 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 - 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) :: 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 if (down_sample) then call s_populate_variables_buffers(bc_type, q_cons_ts(1)%vf) @@ -946,8 +755,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 @@ -986,9 +794,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.") @@ -997,8 +804,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) @@ -1020,18 +827,22 @@ 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 - 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() #: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 @@ -1073,11 +884,10 @@ 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 - ! 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) @@ -1092,7 +902,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) @@ -1106,16 +915,15 @@ 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 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() @@ -1130,13 +938,15 @@ 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 + #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 @@ -1145,18 +955,14 @@ 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 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 @@ -1173,24 +979,20 @@ 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. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() 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 @@ -1198,10 +1000,6 @@ 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. - call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() @@ -1210,10 +1008,11 @@ 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 - !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 +1020,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]') @@ -1229,36 +1028,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]') + $: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]') + $: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 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 +1065,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 @@ -1282,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() @@ -1298,7 +1094,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 @@ -1317,8 +1113,8 @@ 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 end module m_start_up diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index c67375bc01..4ceb4038ba 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -9,29 +9,19 @@ !> @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 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,15 +31,16 @@ 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 + !> Allocate and initialize surface tension module arrays impure subroutine s_initialize_surface_tension_module integer :: j @@ -68,25 +59,24 @@ 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 - !> @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 + !> 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 + 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 +84,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 +113,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(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) + ! 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 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 +155,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 +197,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 @@ -239,14 +215,13 @@ 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 - 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 @@ -259,8 +234,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 +245,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 +257,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 +272,10 @@ 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(real(c_divs(num_dims + 1)%sf(j, k, l), kind=wp)) end do end do end do @@ -321,17 +292,14 @@ contains 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 + !> 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) - 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 + 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 :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno', 'WENO_TYPE'),('muscl', 'MUSCL_TYPE')] @@ -342,20 +310,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 @@ -402,8 +367,9 @@ 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 do j = 1, num_dims diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 1e39da0926..4a741a4068 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -8,94 +8,60 @@ !> @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 - use m_fftw - use m_nvtx - use m_thermochem, only: num_species - use m_body_forces - use m_derived_variables 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 - - $: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 + 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]') + + !> @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. + !> Initialize the time steppers module impure subroutine s_initialize_time_steppers_module + #ifdef FRONTIER_UNIFIED use hipfort use hipfort_hipmalloc @@ -104,12 +70,12 @@ 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 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 +92,27 @@ 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 @@ -161,8 +122,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 @@ -170,14 +130,15 @@ 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 + 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)) @@ -185,27 +146,26 @@ 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)) + 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 +176,17 @@ 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 +198,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 @@ -254,9 +212,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 @@ -267,129 +224,110 @@ 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 +341,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)) @@ -505,34 +436,34 @@ 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. + !> 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 - !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 +472,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 +504,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 +529,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 +575,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() @@ -674,26 +596,17 @@ 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 + 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 +614,41 @@ 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. + !> Compute 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 - type(vector_field) :: gm_alpha_qp - - real(wp) :: dt_local - integer :: j, k, l !< Generic loop iterators + 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 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]') @@ -776,20 +684,14 @@ 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 - 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 +701,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 @@ -811,12 +712,12 @@ 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 - integer :: i - logical :: forces_computed + integer :: i + logical :: forces_computed call nvtxStartRange("PROPAGATE-IMMERSED-BOUNDARIES") @@ -834,12 +735,13 @@ 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 @: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) @@ -850,18 +752,25 @@ 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 @@ -871,14 +780,11 @@ 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 - - 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 +798,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 +810,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 +822,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 @@ -928,7 +834,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 @@ -949,13 +855,13 @@ contains !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_time_steppers_module + #ifdef FRONTIER_UNIFIED use hipfort 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 9c6e4ad4d8..5f7022714f 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -7,39 +7,29 @@ !> @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 - 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. + !> Initialize the viscous module 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)) @@ -48,44 +38,34 @@ 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 - ! 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) + !> Compute viscous stress tensor near cylindrical axis, avoiding 1/r singularity at y_cb(-1)=0 + 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 + #: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 - 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 - $: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 +81,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 +137,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -175,33 +154,26 @@ 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) + ! 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)) + 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) + 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 +183,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 +239,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -285,29 +256,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 +280,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 +336,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -392,47 +353,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 +435,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -501,133 +452,81 @@ 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 $:END_GPU_PARALLEL_LOOP() 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 + 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, & - 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 + & 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) - integer :: i, j, k, l + 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 - do i = 1, num_dims + 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 + 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 - ! 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), & - 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 - + 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]') 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 +534,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 +548,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 +557,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 +564,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 +578,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 +592,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 +609,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 +626,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 +643,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 +663,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 +677,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 +691,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 +709,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 +727,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 +744,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 +762,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 +779,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 +796,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 +812,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,52 +825,37 @@ 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) + !> 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) 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 + 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 :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] @@ -1047,37 +866,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 +910,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 +923,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 @@ -1129,19 +942,19 @@ 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. - 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 + !> 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, & - integer :: recon_dir !< Coordinate direction of the WENO reconstruction + & 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 - 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 +963,30 @@ 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 +1006,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 +1019,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 @@ -1233,43 +1038,17 @@ 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 - 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) + !> 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 - 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,12 +1059,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 @@ -1293,12 +1069,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,13 +1080,10 @@ contains ! END: First-Order Spatial Derivatives in x-direction ! First-Order Spatial Derivatives in y-direction - elseif (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. + 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. $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -1322,12 +1091,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 @@ -1338,12 +1103,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 @@ -1351,37 +1113,27 @@ 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 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 +1150,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 +1167,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 +1179,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 +1189,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 +1200,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 +1211,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 +1227,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 +1236,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 +1247,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 +1256,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 +1267,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,9 +1277,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, 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() @@ -1550,19 +1288,19 @@ 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]') - 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 +1316,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 @@ -1591,14 +1332,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 @@ -1612,7 +1353,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 0a7ca855d3..c2b1cc5ac7 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -7,95 +7,82 @@ !> @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 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 - 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 !> @{ 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. + !> Initialize the WENO module impure subroutine s_initialize_weno_module if (weno_order == 1) return @@ -105,7 +92,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 +105,20 @@ 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)) - ! 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) - @: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 +134,18 @@ 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)) + & 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 +154,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)) + & 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. - !! @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) - 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 + ! Compute WENO coefficients for a given coordinate direction. Shu (1997) - type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction - - integer :: i !< Generic loop iterator + 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) :: 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 - ! 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,34 +198,27 @@ 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)) + ! 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) - 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)) + ! 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) - 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 - + ! 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 - ! 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 @@ -272,351 +233,621 @@ 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))) + ! 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))) + 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))) + + ! 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))) + 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) - + ! 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)) & + & **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 - ! 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 - 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 - + 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" - ! 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. - - 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))) !& + ! 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, 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))) + 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) + 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 @@ -625,46 +856,44 @@ contains 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) + !> 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) - 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 - 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), dimension(-3:3) :: v !< temporary field value array for clarity (WENO7 only) + 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 +941,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 +952,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 +988,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 +1024,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,76 +1037,66 @@ 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 - ! Fu, et al. (2016) - ! Fu''s code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 + 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 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 @@ -889,33 +1106,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 +1141,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 +1148,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,161 +1158,144 @@ 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 - ! 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 !& + ! (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 + 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 - - else ! TENO + 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 !& - - 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 !& + ! 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)) + v(-1) & + & *(11003._wp*v(-1) - 9402._wp*v(0)) + v(0)*(2107._wp*v(0)))/240._wp + weno_eps #:endif 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 - ! Castro, et al. (2010) - ! Don & Borges (2013) also helps - tau = abs(beta(3) - beta(0)) ! Equation 50 + 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 + 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 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 +1304,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 +1354,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,33 +1374,21 @@ 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. - !! @param v_vf Cell-averaged variables - !! @param weno_dir Coordinate direction of the WENO reconstruction - subroutine s_initialize_weno(v_vf, & - weno_dir) + !> 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 + type(scalar_field), dimension(:), intent(in) :: v_vf + integer, intent(in) :: weno_dir + integer :: j, k, l, q - integer, intent(IN) :: weno_dir + ! Determine WENO-reconstructed variables and map coordinate directions - 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 v_size = ubound(v_vf, 1) $:GPU_UPDATE(device='[v_size]') @@ -1257,47 +1442,24 @@ 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 - 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 - - ! 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), 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. - - 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. - + ! Monotonicity-preserving bounds, Suresh & Huynh JCP (1997) + 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 @@ -1306,121 +1468,65 @@ 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))) + ! 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 + 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 @@ -1430,14 +1536,13 @@ contains 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(v_rs_ws_x) ! Deallocating WENO coefficients in x-direction @@ -1448,7 +1553,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) @@ -1458,7 +1562,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 e65722e191..1d0ad72035 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -2,47 +2,40 @@ !! @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_global_parameters use m_start_up - use m_time_steppers - use m_nvtx 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 @@ -68,22 +61,21 @@ program p_main finaltime = t_step_stop*dt end if - call nvtxEndRange ! INIT + call nvtxEndRange ! INIT 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 @@ -103,12 +95,11 @@ program p_main call system_clock(cpu_end) end do - call nvtxEndRange ! Simulation + call nvtxEndRange ! Simulation deallocate (proc_time, io_proc_time) 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..c3ecad2e02 100644 --- a/src/syscheck/syscheck.fpp +++ b/src/syscheck/syscheck.fpp @@ -102,7 +102,6 @@ program syscheck @:LOG("") @:LOG("Syscheck: PASSED.") - end program syscheck subroutine assert(condition) 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