diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 27a1bf3385..36fa74ebc3 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -146,8 +146,8 @@ end if #:enddef -#define t_vec3 real(kind(0d0)), dimension(1:3) -#define t_mat4x4 real(kind(0d0)), dimension(1:4,1:4) +#define t_vec3 real(wp), dimension(1:3) +#define t_mat4x4 real(wp), dimension(1:4,1:4) #:def ASSERT(predicate, message = None) if (.not. (${predicate}$)) then diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index 43147ad6bd..5f0c959ef5 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -61,7 +61,7 @@ contains !! Called by s_check_inputs_common for simulation and post-processing subroutine s_check_inputs_time_stepping if (cfl_dt) then - @:PROHIBIT(cfl_target < 0 .or. cfl_target > 1d0) + @:PROHIBIT(cfl_target < 0 .or. cfl_target > 1._wp) @:PROHIBIT(t_stop <= 0) @:PROHIBIT(t_save <= 0) @:PROHIBIT(t_save > t_stop) @@ -144,10 +144,10 @@ contains @:PROHIBIT(relax .and. model_eqns /= 3, "phase change requires model_eqns = 3") @:PROHIBIT(relax .and. relax_model < 0, "relax_model must be in between 0 and 6") @:PROHIBIT(relax .and. relax_model > 6, "relax_model must be in between 0 and 6") - @:PROHIBIT(relax .and. palpha_eps <= 0d0, "palpha_eps must be positive") - @:PROHIBIT(relax .and. palpha_eps >= 1d0, "palpha_eps must be less than 1") - @:PROHIBIT(relax .and. ptgalpha_eps <= 0d0, "ptgalpha_eps must be positive") - @:PROHIBIT(relax .and. ptgalpha_eps >= 1d0, "ptgalpha_eps must be less than 1") + @:PROHIBIT(relax .and. palpha_eps <= 0._wp, "palpha_eps must be positive") + @:PROHIBIT(relax .and. palpha_eps >= 1._wp, "palpha_eps must be less than 1") + @:PROHIBIT(relax .and. ptgalpha_eps <= 0._wp, "ptgalpha_eps must be positive") + @:PROHIBIT(relax .and. ptgalpha_eps >= 1._wp, "ptgalpha_eps must be less than 1") @:PROHIBIT((.not. relax) .and. & ((relax_model /= dflt_int) .or. (.not. f_is_default(palpha_eps)) .or. (.not. f_is_default(ptgalpha_eps))), & "relax is not set as true, but other phase change parameters have been modified. " // & @@ -262,27 +262,27 @@ contains do i = 1, num_fluids call s_int_to_str(i, iStr) - @:PROHIBIT(.not. f_is_default(fluid_pp(i)%gamma) .and. fluid_pp(i)%gamma <= 0d0, & + @:PROHIBIT(.not. f_is_default(fluid_pp(i)%gamma) .and. fluid_pp(i)%gamma <= 0._wp, & "fluid_pp("//trim(iStr)//")%gamma must be positive") @:PROHIBIT(model_eqns == 1 .and. (.not. f_is_default(fluid_pp(i)%gamma)), & "model_eqns = 1 does not support fluid_pp("//trim(iStr)//")%gamma") - @:PROHIBIT((i <= num_fluids + bub_fac .and. fluid_pp(i)%gamma <= 0d0) .or. & + @:PROHIBIT((i <= num_fluids + bub_fac .and. fluid_pp(i)%gamma <= 0._wp) .or. & (i > num_fluids + bub_fac .and. (.not. f_is_default(fluid_pp(i)%gamma))), & "for fluid_pp("//trim(iStr)//")%gamma") - @:PROHIBIT(.not. f_is_default(fluid_pp(i)%pi_inf) .and. fluid_pp(i)%pi_inf < 0d0, & + @:PROHIBIT(.not. f_is_default(fluid_pp(i)%pi_inf) .and. fluid_pp(i)%pi_inf < 0._wp, & "fluid_pp("//trim(iStr)//")%pi_inf must be non-negative") @:PROHIBIT(model_eqns == 1 .and. (.not. f_is_default(fluid_pp(i)%pi_inf)), & "model_eqns = 1 does not support fluid_pp("//trim(iStr)//")%pi_inf") - @:PROHIBIT((i <= num_fluids + bub_fac .and. fluid_pp(i)%pi_inf < 0d0) .or. & + @:PROHIBIT((i <= num_fluids + bub_fac .and. fluid_pp(i)%pi_inf < 0._wp) .or. & (i > num_fluids + bub_fac .and. (.not. f_is_default(fluid_pp(i)%pi_inf))), & "for fluid_pp("//trim(iStr)//")%pi_inf") - @:PROHIBIT(fluid_pp(i)%cv < 0d0, & + @:PROHIBIT(fluid_pp(i)%cv < 0._wp, & "fluid_pp("//trim(iStr)//")%cv must be positive") end do end subroutine s_check_inputs_stiffened_eos @@ -290,7 +290,7 @@ contains !> Checks constraints on the surface tension parameters. !! Called by s_check_inputs_common for all three stages subroutine s_check_inputs_surface_tension - @:PROHIBIT(.not. f_is_default(sigma) .and. sigma < 0d0, & + @:PROHIBIT(.not. f_is_default(sigma) .and. sigma < 0._wp, & "sigma must be greater than or equal to zero") @:PROHIBIT(.not. f_is_default(sigma) .and. model_eqns /= 3, & @@ -301,9 +301,9 @@ contains !! Called by s_check_inputs_common for all three stages subroutine s_check_inputs_moving_bc #:for X, VB2, VB3 in [('x', 'vb2', 'vb3'), ('y', 'vb3', 'vb1'), ('z', 'vb1', 'vb2')] - if (any((/bc_${X}$%vb1, bc_${X}$%vb2, bc_${X}$%vb3/) /= 0d0)) then + if (any((/bc_${X}$%vb1, bc_${X}$%vb2, bc_${X}$%vb3/) /= 0._wp)) then if (bc_${X}$%beg == -15) then - if (any((/bc_${X}$%${VB2}$, bc_${X}$%${VB3}$/) /= 0d0)) then + if (any((/bc_${X}$%${VB2}$, bc_${X}$%${VB3}$/) /= 0._wp)) then call s_mpi_abort("bc_${X}$%beg must be -15 if "// & "bc_${X}$%${VB2}$ or bc_${X}$%${VB3}$ "// & "is set. Exiting ...") @@ -316,9 +316,9 @@ contains #:endfor #:for X, VE2, VE3 in [('x', 've2', 've3'), ('y', 've3', 've1'), ('z', 've1', 've2')] - if (any((/bc_${X}$%ve1, bc_${X}$%ve2, bc_${X}$%ve3/) /= 0d0)) then + if (any((/bc_${X}$%ve1, bc_${X}$%ve2, bc_${X}$%ve3/) /= 0._wp)) then if (bc_${X}$%end == -15) then - if (any((/bc_${X}$%${VE2}$, bc_${X}$%${VE3}$/) /= 0d0)) then + if (any((/bc_${X}$%${VE2}$, bc_${X}$%${VE3}$/) /= 0._wp)) then call s_mpi_abort("bc_${X}$%end must be -15 if "// & "bc_${X}$%${VE2}$ or bc_${X}$%${VE3}$ "// & "is set. Exiting ...") diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index a39fdb78ae..a8ef8697a6 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -4,13 +4,15 @@ module m_constants + use m_precision_select + character, parameter :: dflt_char = ' ' !< Default string value - real(kind(0d0)), parameter :: dflt_real = -1d6 !< Default real value - real(kind(0d0)), parameter :: sgm_eps = 1d-16 !< Segmentation tolerance - real(kind(0d0)), parameter :: small_alf = 1d-11 !< Small alf tolerance - real(kind(0d0)), parameter :: pi = 3.141592653589793d0 !< Pi - real(kind(0d0)), parameter :: verysmall = 1.d-12 !< Very small number + real(wp), parameter :: dflt_real = -1d6 !< Default real value + real(wp), parameter :: sgm_eps = 1d-16 !< Segmentation tolerance + real(wp), parameter :: small_alf = 1d-11 !< Small alf tolerance + real(wp), parameter :: pi = 3.141592653589793_wp !< Pi + real(wp), parameter :: verysmall = 1.d-12 !< Very small number integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils integer, parameter :: path_len = 400 !< Maximum path length @@ -22,8 +24,8 @@ module m_constants integer, parameter :: num_patches_max = 10 integer, parameter :: pathlen_max = 400 integer, parameter :: nnode = 4 !< Number of QBMM nodes - real(kind(0d0)), parameter :: capillary_cutoff = 1e-6 !< color function gradient magnitude at which to apply the surface tension fluxes - real(kind(0d0)), parameter :: acoustic_spatial_support_width = 2.5d0 !< Spatial support width of acoustic source, used in s_source_spatial - real(kind(0d0)), parameter :: dflt_vcfl_dt = 100d0 !< value of vcfl_dt when viscosity is off for computing adaptive timestep size + real(wp), parameter :: capillary_cutoff = 1e-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 end module m_constants diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index 54dd3edbad..df8b368dcd 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -1,4 +1,5 @@ module m_delay_file_access + use m_precision_select implicit none private @@ -14,7 +15,7 @@ subroutine DelayFileAccess(ProcessRank) integer, intent(in) :: ProcessRank integer :: iDelay, nFileAccessDelayIterations - real(kind(0d0)) :: Number, Dummy + real(wp) :: Number, Dummy nFileAccessDelayIterations & = (ProcessRank/N_PROCESSES_FILE_ACCESS)*FILE_ACCESS_DELAY_UNIT diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 65d4094748..5c0b2a9524 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -9,23 +9,24 @@ module m_derived_types use m_constants !< Constants + use m_precision_select use m_thermochem !< Thermodynamic properties implicit none !> Derived type adding the field position (fp) as an attribute type field_position - real(kind(0d0)), allocatable, dimension(:, :, :) :: fp !< Field position + real(wp), allocatable, dimension(:, :, :) :: fp !< Field position end type field_position !> Derived type annexing a scalar field (SF) type scalar_field - real(kind(0d0)), pointer, dimension(:, :, :) :: sf => null() + real(wp), pointer, dimension(:, :, :) :: sf => null() end type scalar_field !> Derived type for bubble variables pb and mv at quadrature nodes (qbmm) type pres_field - real(kind(0d0)), pointer, dimension(:, :, :, :, :) :: sf => null() + real(wp), pointer, dimension(:, :, :, :, :) :: sf => null() end type pres_field !> Derived type annexing an integer scalar field (SF) @@ -52,18 +53,18 @@ module m_derived_types type int_bounds_info integer :: beg integer :: end - real(kind(0d0)) :: vb1 - real(kind(0d0)) :: vb2 - real(kind(0d0)) :: vb3 - real(kind(0d0)) :: ve1 - real(kind(0d0)) :: ve2 - real(kind(0d0)) :: ve3 + real(wp) :: vb1 + real(wp) :: vb2 + real(wp) :: vb3 + real(wp) :: ve1 + real(wp) :: ve2 + real(wp) :: ve3 end type int_bounds_info !> Derived type adding beginning (beg) and end bounds info as attributes type bounds_info - real(kind(0d0)) :: beg - real(kind(0d0)) :: end + real(wp) :: beg + real(wp) :: end end type bounds_info !> bounds for the bubble dynamic variables @@ -96,12 +97,12 @@ module m_derived_types integer :: spc !< !! Number of samples per cell to use when discretizing the STL object. - real(kind(0d0)) :: threshold !< + real(wp) :: threshold !< !! Threshold to turn on smoothen STL patch. end type ic_model_parameters type :: t_triangle - real(kind(0d0)), dimension(1:3, 1:3) :: v ! Vertices of the triangle + real(wp), dimension(1:3, 1:3) :: v ! Vertices of the triangle t_vec3 :: n ! Normal vector end type t_triangle @@ -128,24 +129,24 @@ module m_derived_types integer :: geometry !< Type of geometry for the patch - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid !< + 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(kind(0d0)) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(kind(0d0)) :: radius !< Dimensions of the patch. radius. + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. - real(kind(0d0)), dimension(3) :: radii !< + 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. type(ic_model_parameters) :: model !< Model parameters - real(kind(0d0)) :: epsilon, beta !< + real(wp) :: epsilon, beta !< !! The spherical harmonics eccentricity parameters. - real(kind(0d0)), dimension(3) :: normal !< + real(wp), dimension(3) :: normal !< !! Normal vector indicating the orientation of the patch. It is specified !! through its x-, y- and z-components, respectively. logical, dimension(0:num_patches_max - 1) :: alter_patch !< @@ -161,39 +162,39 @@ module m_derived_types integer :: smooth_patch_id !< !! Identity (id) of the patch with which current patch is to get smoothed - real(kind(0d0)) :: smooth_coeff !< + real(wp) :: smooth_coeff !< !! Smoothing coefficient (coeff) adminstrating the size of the stencil of !! cells across which boundaries of the current patch will be smeared out - real(kind(0d0)), dimension(num_fluids_max) :: alpha_rho - real(kind(0d0)) :: rho - real(kind(0d0)), dimension(3) :: vel - real(kind(0d0)) :: pres - real(kind(0d0)), dimension(num_fluids_max) :: alpha - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf !< - real(kind(0d0)) :: cv !< - real(kind(0d0)) :: qv !< - real(kind(0d0)) :: qvp !< + 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(kind(0d0)), dimension(6) :: tau_e + real(wp), dimension(6) :: tau_e !! Elastic stresses added to primitive variables if hypoelasticity = True - real(kind(0d0)) :: R0 !< Bubble size - real(kind(0d0)) :: V0 !< Bubble velocity + real(wp) :: R0 !< Bubble size + real(wp) :: V0 !< Bubble velocity - real(kind(0d0)) :: p0 !< Bubble size - real(kind(0d0)) :: m0 !< Bubble velocity + real(wp) :: p0 !< Bubble size + real(wp) :: m0 !< Bubble velocity integer :: hcid !! id for hard coded initial condition - real(kind(0d0)) :: cf_val !! color function value - real(kind(0d0)) :: Y(1:num_species) + real(wp) :: cf_val !! color function value + real(wp) :: Y(1:num_species) end type ic_patch_parameters @@ -201,15 +202,15 @@ module m_derived_types integer :: geometry !< Type of geometry for the patch - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid !< + 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(kind(0d0)) :: c, p, t, m + real(wp) :: c, p, t, m - real(kind(0d0)) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(kind(0d0)) :: radius !< Dimensions of the patch. radius. - real(kind(0d0)) :: theta + 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 @@ -218,27 +219,27 @@ module m_derived_types !> Derived type annexing the physical parameters (PP) of the fluids. These !! include the specific heat ratio function and liquid stiffness function. type physical_parameters - real(kind(0d0)) :: gamma !< Sp. heat ratio - real(kind(0d0)) :: pi_inf !< Liquid stiffness - real(kind(0d0)), dimension(2) :: Re !< Reynolds number - real(kind(0d0)) :: cv !< heat capacity - real(kind(0d0)) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) - real(kind(0d0)) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) - real(kind(0d0)) :: mul0 !< Bubble viscosity - real(kind(0d0)) :: ss !< Bubble surface tension - real(kind(0d0)) :: pv !< Bubble vapour pressure - real(kind(0d0)) :: gamma_v !< Bubble constants (see Preston (2007), Ando (2010)) - real(kind(0d0)) :: M_v !< Bubble constants (see Preston (2007), Ando (2010)) - real(kind(0d0)) :: mu_v !< Bubble constants (see Preston (2007), Ando (2010)) - real(kind(0d0)) :: k_v !< Bubble constants (see Preston (2007), Ando (2010)) - real(kind(0d0)) :: 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) :: mul0 !< Bubble viscosity + real(wp) :: ss !< Bubble surface tension + real(wp) :: pv !< Bubble vapour pressure + real(wp) :: gamma_v !< Bubble constants (see Preston (2007), Ando (2010)) + real(wp) :: M_v !< Bubble constants (see Preston (2007), Ando (2010)) + real(wp) :: mu_v !< Bubble constants (see Preston (2007), Ando (2010)) + real(wp) :: k_v !< Bubble constants (see Preston (2007), Ando (2010)) + real(wp) :: G end type physical_parameters !> Derived type annexing the flow probe location type probe_parameters - real(kind(0d0)) :: x !< First coordinate location - real(kind(0d0)) :: y !< Second coordinate location - real(kind(0d0)) :: z !< Third coordinate location + real(wp) :: x !< First coordinate location + real(wp) :: y !< Second coordinate location + real(wp) :: z !< Third coordinate location end type probe_parameters type mpi_io_airfoil_ib_var @@ -248,12 +249,12 @@ module m_derived_types !> Derived type annexing integral regions type integral_parameters - real(kind(0d0)) :: xmin !< Min. boundary first coordinate direction - real(kind(0d0)) :: xmax !< Max. boundary first coordinate direction - real(kind(0d0)) :: ymin !< Min. boundary second coordinate direction - real(kind(0d0)) :: ymax !< Max. boundary second coordinate direction - real(kind(0d0)) :: zmin !< Min. boundary third coordinate direction - real(kind(0d0)) :: 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 @@ -261,22 +262,22 @@ module m_derived_types integer :: pulse !< Type of pulse integer :: support !< Type of support logical :: dipole !< Whether the source is a dipole or monopole - real(kind(0d0)), dimension(3) :: loc !< Physical location of acoustic source - real(kind(0d0)) :: mag !< Acoustic pulse magnitude - real(kind(0d0)) :: length !< Length of planar source (2D/3D) - real(kind(0d0)) :: height !< Height of planar source (3D) - real(kind(0d0)) :: wavelength !< Wave length of pulse - real(kind(0d0)) :: frequency !< Frequency of pulse - real(kind(0d0)) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound - real(kind(0d0)) :: gauss_sigma_time !< sigma of Gaussian pulse - real(kind(0d0)) :: npulse !< Number of cycles of pulse - real(kind(0d0)) :: dir !< Direction of pulse - real(kind(0d0)) :: delay !< Time-delay of pulse start - real(kind(0d0)) :: foc_length ! < Focal length of transducer - real(kind(0d0)) :: aperture ! < Aperture diameter of transducer - real(kind(0d0)) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array - real(kind(0d0)) :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array - real(kind(0d0)) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array + 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 integer :: num_elements !< Number of elements in the acoustic array integer :: element_on !< Element in the acoustic array to turn on end type acoustic_parameters @@ -284,18 +285,18 @@ module m_derived_types !> Acoustic source source_spatial pre-calculated values type source_spatial_type integer, dimension(:, :), allocatable :: coord !< List of grid points indices with non-zero source_spatial values - real(kind(0d0)), dimension(:), allocatable :: val !< List of non-zero source_spatial values - real(kind(0d0)), dimension(:), allocatable :: angle !< List of angles with x-axis for mom source term vector - real(kind(0d0)), dimension(:, :), allocatable :: xyz_to_r_ratios !< List of [xyz]/r for mom source term vector + real(wp), dimension(:), allocatable :: val !< List of non-zero source_spatial values + real(wp), dimension(:), allocatable :: angle !< List of angles with x-axis for mom source term vector + real(wp), dimension(:, :), allocatable :: xyz_to_r_ratios !< List of [xyz]/r for mom source term vector end type source_spatial_type !> Ghost Point for Immersed Boundaries type ghost_point - real(kind(0d0)), dimension(3) :: loc !< Physical location of the ghost point - real(kind(0d0)), dimension(3) :: ip_loc !< Physical location of the image point + real(wp), 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(kind(0d0)), dimension(2, 2, 2) :: interp_coeffs !< Interpolation Coefficients of image point + 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 logical :: slip integer, dimension(3) :: DB diff --git a/src/common/m_eigen_solver.f90 b/src/common/m_eigen_solver.f90 index 8356f78fc6..80198afbbb 100644 --- a/src/common/m_eigen_solver.f90 +++ b/src/common/m_eigen_solver.f90 @@ -8,6 +8,8 @@ !! modifications for compatibility. module m_eigen_solver + use m_precision_select + implicit none private; @@ -33,10 +35,10 @@ module m_eigen_solver !! @param ierr an error completion code subroutine cg(nm, nl, ar, ai, wr, wi, zr, zi, fv1, fv2, fv3, ierr) integer, intent(in) :: nm, nl - real(kind(0d0)), dimension(nm, nl), intent(inout) :: ar, ai - real(kind(0d0)), dimension(nl), intent(out) :: wr, wi - real(kind(0d0)), dimension(nm, nl), intent(out) :: zr, zi - real(kind(0d0)), dimension(nl), intent(out) :: fv1, fv2, fv3 + real(wp), dimension(nm, nl), intent(inout) :: ar, ai + real(wp), dimension(nl), intent(out) :: wr, wi + real(wp), dimension(nm, nl), intent(out) :: zr, zi + real(wp), dimension(nl), intent(out) :: fv1, fv2, fv3 integer, intent(out) :: ierr integer :: is1, is2 @@ -76,15 +78,15 @@ end subroutine cg !! factors used. subroutine cbal(nm, nl, ar, ai, low, igh, scale) integer, intent(in) :: nm, nl - real(kind(0d0)), dimension(nm, nl), intent(inout) :: ar, ai + real(wp), dimension(nm, nl), intent(inout) :: ar, ai integer, intent(out) :: low, igh - real(kind(0d0)), dimension(nl), intent(out) :: scale + real(wp), dimension(nl), intent(out) :: scale integer :: i, j, k, l, ml, jj, iexc - real(kind(0d0)) :: c, f, g, r, s, b2, radix + real(wp) :: c, f, g, r, s, b2, radix logical :: noconv - radix = 16.0d0 + radix = 16.0_wp b2 = radix*radix k = 1 @@ -124,7 +126,7 @@ subroutine cbal(nm, nl, ar, ai, low, igh, scale) do 110 i = 1, l if (i == j) go to 110 - if (ar(j, i) /= 0.0d0 .or. ai(j, i) /= 0.0d0) go to 120 + if (ar(j, i) /= 0.0_wp .or. ai(j, i) /= 0.0_wp) go to 120 110 end do ml = l @@ -141,7 +143,7 @@ subroutine cbal(nm, nl, ar, ai, low, igh, scale) do 150 i = k, l if (i == j) go to 150 - if (ar(i, j) /= 0.0d0 .or. ai(i, j) /= 0.0d0) go to 170 + if (ar(i, j) /= 0.0_wp .or. ai(i, j) /= 0.0_wp) go to 170 150 end do ml = k @@ -150,14 +152,14 @@ subroutine cbal(nm, nl, ar, ai, low, igh, scale) 170 end do ! .......... now balance the submatrix in rows k to l .......... do 180 i = k, l - scale(i) = 1.0d0 + scale(i) = 1.0_wp 180 end do ! .......... iterative loop for norm reduction .......... 190 noconv = .false. do 270 i = k, l - c = 0.0d0 - r = 0.0d0 + c = 0.0_wp + r = 0.0_wp do 200 j = k, l if (j == i) go to 200 @@ -165,9 +167,9 @@ subroutine cbal(nm, nl, ar, ai, low, igh, scale) r = r + dabs(ar(i, j)) + dabs(ai(i, j)) 200 end do ! .......... guard against zero c or r due to underflow .......... - if (c == 0.0d0 .or. r == 0.0d0) go to 270 + if (c == 0.0_wp .or. r == 0.0_wp) go to 270 g = r/radix - f = 1.0d0 + f = 1.0_wp s = c + r 210 if (c >= g) go to 220 f = f*radix @@ -179,8 +181,8 @@ subroutine cbal(nm, nl, ar, ai, low, igh, scale) c = c/b2 go to 230 ! .......... now balance .......... -240 if ((c + r)/f >= 0.95d0*s) go to 270 - g = 1.0d0/f +240 if ((c + r)/f >= 0.95_wp*s) go to 270 + g = 1.0_wp/f scale(i) = scale(i)*f noconv = .true. @@ -222,11 +224,11 @@ end subroutine cbal !! @param orti further information about the transformations subroutine corth(nm, nl, low, igh, ar, ai, ortr, orti) integer, intent(in) :: nm, nl, low, igh - real(kind(0d0)), dimension(nm, nl), intent(inout) :: ar, ai - real(kind(0d0)), dimension(igh), intent(out) :: ortr, orti + real(wp), dimension(nm, nl), intent(inout) :: ar, ai + real(wp), dimension(igh), intent(out) :: ortr, orti integer :: i, j, ml, ii, jj, la, mp, kp1, mll - real(kind(0d0)) :: f, g, h, fi, fr, scale, c + real(wp) :: f, g, h, fi, fr, scale, c mll = 6 @@ -235,15 +237,15 @@ subroutine corth(nm, nl, low, igh, ar, ai, ortr, orti) if (la < kp1) go to 200 do 180 ml = kp1, la - h = 0.0d0 - ortr(ml) = 0.0d0 - orti(ml) = 0.0d0 - scale = 0.0d0 + h = 0.0_wp + ortr(ml) = 0.0_wp + orti(ml) = 0.0_wp + scale = 0.0_wp ! .......... scale column (algol tol then not needed) .......... do 90 i = ml, igh scale = scale + dabs(ar(i, ml - 1)) + dabs(ai(i, ml - 1)) 90 end do - if (scale == 0d0) go to 180 + if (scale == 0._wp) go to 180 mp = ml + igh ! .......... for i=igh step -1 until ml do -- .......... do 100 ii = ml, igh @@ -255,19 +257,19 @@ subroutine corth(nm, nl, low, igh, ar, ai, ortr, orti) ! g = dsqrt(h) call pythag(ortr(ml), orti(ml), f) - if (f == 0d0) go to 103 + if (f == 0._wp) go to 103 h = h + f*g g = g/f - ortr(ml) = (1.0d0 + g)*ortr(ml) - orti(ml) = (1.0d0 + g)*orti(ml) + ortr(ml) = (1.0_wp + g)*ortr(ml) + orti(ml) = (1.0_wp + g)*orti(ml) go to 105 103 ortr(ml) = g ar(ml, ml - 1) = scale ! .......... form (i-(u*ut)/h) * a .......... 105 do 130 j = ml, nl - fr = 0.0d0 - fi = 0.0d0 + fr = 0.0_wp + fi = 0.0_wp ! .......... for i=igh step -1 until ml do -- .......... do 110 ii = ml, igh i = mp - ii @@ -286,8 +288,8 @@ subroutine corth(nm, nl, low, igh, ar, ai, ortr, orti) 130 end do ! .......... form (i-(u*ut)/h)*a*(i-(u*ut)/h) .......... do 160 i = 1, igh - fr = 0.0d0 - fi = 0.0d0 + fr = 0.0_wp + fi = 0.0_wp ! .......... for j=igh step -1 until ml do -- .......... do 140 jj = ml, igh j = mp - jj @@ -344,25 +346,25 @@ end subroutine corth !! @param ierr an error completion code subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) integer, intent(in) :: nm, nl, low, igh - real(kind(0d0)), dimension(nm, nl), intent(inout) :: hr, hi - real(kind(0d0)), dimension(nl), intent(out) :: wr, wi - real(kind(0d0)), dimension(nm, nl), intent(out) :: zr, zi - real(kind(0d0)), dimension(igh), intent(inout) :: ortr, orti + real(wp), dimension(nm, nl), intent(inout) :: hr, hi + real(wp), dimension(nl), intent(out) :: wr, wi + real(wp), dimension(nm, nl), intent(out) :: zr, zi + real(wp), dimension(igh), intent(inout) :: ortr, orti integer, intent(out) :: ierr integer :: i, j, k, l, ml, en, ii, jj, ll, nn, ip1, itn, its, lp1, enm1, iend - real(kind(0d0)) :: si, sr, ti, tr, xi, xr, xxi, xxr, yi, yr, zzi, zzr, & - norm, tst1, tst2, c, d + real(wp) :: si, sr, ti, tr, xi, xr, xxi, xxr, yi, yr, zzi, zzr, & + norm, tst1, tst2, c, d ! ierr = 0 ! .......... initialize eigenvector matrix .......... do 101 j = 1, nl ! do 100 i = 1, nl - zr(i, j) = 0.0d0 - zi(i, j) = 0.0d0 + zr(i, j) = 0.0_wp + zi(i, j) = 0.0_wp 100 end do - zr(j, j) = 1.0d0 + zr(j, j) = 1.0_wp 101 end do ! .......... form the matrix of accumulated transformations ! from the information left by corth .......... @@ -373,8 +375,8 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! .......... for i=igh-1 step -1 until low+1 do -- .......... 105 do 140 ii = 1, iend i = igh - ii - if (dabs(ortr(i)) == 0d0 .and. dabs(orti(i)) == 0d0) go to 140 - if (dabs(hr(i, i - 1)) == 0d0 .and. dabs(hi(i, i - 1)) == 0d0) go to 140 + if (dabs(ortr(i)) == 0._wp .and. dabs(orti(i)) == 0._wp) go to 140 + if (dabs(hr(i, i - 1)) == 0._wp .and. dabs(hi(i, i - 1)) == 0._wp) go to 140 ! .......... norm below is negative of h formed in corth .......... norm = hr(i, i - 1)*ortr(i) + hi(i, i - 1)*orti(i) ip1 = i + 1 @@ -385,8 +387,8 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) 110 end do ! do 130 j = i, igh - sr = 0.0d0 - si = 0.0d0 + sr = 0.0_wp + si = 0.0_wp ! do 115 k = i, igh sr = sr + ortr(k)*zr(k, j) + orti(k)*zi(k, j) @@ -409,12 +411,12 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! do 170 i = l, igh ll = min0(i + 1, igh) - if (dabs(hi(i, i - 1)) == 0d0) go to 170 + if (dabs(hi(i, i - 1)) == 0._wp) go to 170 call pythag(hr(i, i - 1), hi(i, i - 1), norm) yr = hr(i, i - 1)/norm yi = hi(i, i - 1)/norm hr(i, i - 1) = norm - hi(i, i - 1) = 0.0d0 + hi(i, i - 1) = 0.0_wp ! do 155 j = i, nl si = yr*hi(i, j) - yi*hr(i, j) @@ -442,8 +444,8 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) 200 end do ! en = igh - tr = 0.0d0 - ti = 0.0d0 + tr = 0.0_wp + ti = 0.0_wp itn = 30*nl ! .......... search for next eigenvalue .......... 220 if (en < low) go to 680 @@ -467,11 +469,11 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) si = hi(en, en) xr = hr(enm1, en)*hr(en, enm1) xi = hi(enm1, en)*hr(en, enm1) - if (xr == 0.0d0 .and. xi == 0.0d0) go to 340 - yr = (hr(enm1, enm1) - sr)/2.0d0 - yi = (hi(enm1, enm1) - si)/2.0d0 - call csroot(yr**2 - yi**2 + xr, 2.0d0*yr*yi + xi, zzr, zzi) - if (yr*zzr + yi*zzi >= 0.0d0) go to 310 + if (xr == 0.0_wp .and. xi == 0.0_wp) go to 340 + yr = (hr(enm1, enm1) - sr)/2.0_wp + yi = (hi(enm1, enm1) - si)/2.0_wp + call csroot(yr**2 - yi**2 + xr, 2.0_wp*yr*yi + xi, zzr, zzi) + if (yr*zzr + yi*zzi >= 0.0_wp) go to 310 zzr = -zzr zzi = -zzi 310 call cdiv(xr, xi, yr + zzr, yi + zzi, xxr, xxi) @@ -480,7 +482,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) go to 340 ! .......... form exceptional shift .......... 320 sr = dabs(hr(en, enm1)) + dabs(hr(enm1, en - 2)) - si = 0.0d0 + si = 0.0_wp ! 340 do 360 i = low, en hr(i, i) = hr(i, i) - sr @@ -496,7 +498,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! do 500 i = lp1, en sr = hr(i, i - 1) - hr(i, i - 1) = 0.0d0 + hr(i, i - 1) = 0.0_wp call pythag(hr(i - 1, i - 1), hi(i - 1, i - 1), c) call pythag(c, sr, norm) xr = hr(i - 1, i - 1)/norm @@ -504,7 +506,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) xi = hi(i - 1, i - 1)/norm wi(i - 1) = xi hr(i - 1, i - 1) = norm - hi(i - 1, i - 1) = 0.0d0 + hi(i - 1, i - 1) = 0.0_wp hi(i, i - 1) = sr/norm ! do 490 j = i, nl @@ -521,12 +523,12 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) 500 end do ! si = hi(en, en) - if (dabs(si) == 0d0) go to 540 + if (dabs(si) == 0._wp) go to 540 call pythag(hr(en, en), si, norm) sr = hr(en, en)/norm si = si/norm hr(en, en) = norm - hi(en, en) = 0.0d0 + hi(en, en) = 0.0_wp if (en == nl) go to 540 ip1 = en + 1 ! @@ -543,7 +545,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! do 580 i = 1, j yr = hr(i, j - 1) - yi = 0.0d0 + yi = 0.0_wp zzr = hr(i, j) zzi = hi(i, j) if (i == j) go to 560 @@ -566,7 +568,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) 590 end do 600 end do ! - if (dabs(si) == 0d0) go to 240 + if (dabs(si) == 0._wp) go to 240 ! do 630 i = 1, en yr = hr(i, en) @@ -592,7 +594,7 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) go to 220 ! .......... all roots found. backsubstitute to find ! vectors of upper triangular form .......... -680 norm = 0.0d0 +680 norm = 0.0_wp ! do i = 1, nl do j = i, nl @@ -601,20 +603,20 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) end do end do ! - if (nl == 1 .or. norm == 0d0) go to 1001 + if (nl == 1 .or. norm == 0._wp) go to 1001 ! .......... for en=nl step -1 until 2 do -- .......... do 800 nn = 2, nl en = nl + 2 - nn xr = wr(en) xi = wi(en) - hr(en, en) = 1.0d0 - hi(en, en) = 0.0d0 + hr(en, en) = 1.0_wp + hi(en, en) = 0.0_wp enm1 = en - 1 ! .......... for i=en-1 step -1 until 1 do -- .......... do 780 ii = 1, enm1 i = en - ii - zzr = 0.0d0 - zzi = 0.0d0 + zzr = 0.0_wp + zzi = 0.0_wp ip1 = i + 1 do 740 j = ip1, en @@ -624,19 +626,19 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ! yr = xr - wr(i) yi = xi - wi(i) - if (yr /= 0.0d0 .or. yi /= 0.0d0) go to 765 + if (yr /= 0.0_wp .or. yi /= 0.0_wp) go to 765 tst1 = norm yr = tst1 -760 yr = 0.01d0*yr +760 yr = 0.01_wp*yr tst2 = norm + yr if (tst2 > tst1) go to 760 765 continue call cdiv(zzr, zzi, yr, yi, hr(i, en), hi(i, en)) ! .......... overflow control .......... tr = dabs(hr(i, en)) + dabs(hi(i, en)) - if (tr == 0.0d0) go to 780 + if (tr == 0.0_wp) go to 780 tst1 = tr - tst2 = tst1 + 1.0d0/tst1 + tst2 = tst1 + 1.0_wp/tst1 if (tst2 > tst1) go to 780 do 770 j = i, en hr(j, en) = hr(j, en)/tr @@ -665,8 +667,8 @@ subroutine comqr2(nm, nl, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr) ml = min0(j, igh) ! do i = low, igh - zzr = 0.0d0 - zzi = 0.0d0 + zzr = 0.0_wp + zzi = 0.0_wp ! do 860 k = low, ml zzr = zzr + zr(i, k)*hr(k, j) - zi(i, k)*hi(k, j) @@ -721,7 +723,7 @@ subroutine cbabk2(nm, nl, low, igh, scale, ml, zr, zi) s = scale(i) ! .......... left hand eigenvectors are back transformed ! if the foregoing statement is replaced by -! s=1.0d0/scale(i). .......... +! s=1.0_wp/scale(i). .......... do 100 j = 1, ml zr(i, j) = zr(i, j)*s zi(i, j) = zi(i, j)*s @@ -752,66 +754,66 @@ subroutine cbabk2(nm, nl, low, igh, scale, ml, zr, zi) end subroutine cbabk2 subroutine csroot(xr, xi, yr, yi) - real(kind(0d0)), intent(in) :: xr, xi - real(kind(0d0)), intent(out) :: yr, yi + real(wp), intent(in) :: xr, xi + real(wp), intent(out) :: yr, yi ! ! (yr,yi) = complex dsqrt(xr,xi) ! branch chosen so that yr .ge. 0.0 and sign(yi) .eq. sign(xi) ! - real(kind(0d0)) :: s, tr, ti, c + real(wp) :: s, tr, ti, c tr = xr ti = xi call pythag(tr, ti, c) - s = dsqrt(0.5d0*(c + dabs(tr))) - if (tr >= 0.0d0) yr = s - if (ti < 0.0d0) s = -s - if (tr <= 0.0d0) yi = s - if (tr < 0.0d0) yr = 0.5d0*(ti/yi) - if (tr > 0.0d0) yi = 0.5d0*(ti/yr) + s = dsqrt(0.5_wp*(c + dabs(tr))) + if (tr >= 0.0_wp) yr = s + if (ti < 0.0_wp) s = -s + if (tr <= 0.0_wp) yi = s + if (tr < 0.0_wp) yr = 0.5_wp*(ti/yi) + if (tr > 0.0_wp) yi = 0.5_wp*(ti/yr) return end subroutine csroot subroutine cdiv(ar, ai, br, bi, cr, ci) - real(kind(0d0)), intent(in) :: ar, ai, br, bi - real(kind(0d0)), intent(out) :: cr, ci - real(kind(0d0)) :: s, ars, ais, brs, bis + real(wp), intent(in) :: ar, ai, br, bi + real(wp), intent(out) :: cr, ci + real(wp) :: s, ars, ais, brs, bis ! ! complex division, (cr,ci) = (ar,ai)/(br,bi) ! ! (ar + i*ai) * (br - i*bi) /(br**2 + bi**2) ! ((ar*br + i*ai*br) + (-i*ar*bi + ai*bi)) /(br**2 + bi**2) ! (ar*br + ai*bi + i*(ai*br - ar*bi)) /(br**2 + bi**2) - ! cr = (ar*br + ai*bi) / (br**2d0 + bi**2d0) - ! ci = (ai*br - ar*bi) / (br**2d0 + bi**2d0) + ! cr = (ar*br + ai*bi) / (br**2._wp + bi**2._wp) + ! ci = (ai*br - ar*bi) / (br**2._wp + bi**2._wp) s = dabs(br) + dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s - s = brs**2d0 + bis**2d0 + s = brs**2._wp + bis**2._wp cr = (ars*brs + ais*bis)/s ci = (ais*brs - ars*bis)/s return end subroutine cdiv subroutine pythag(a, b, c) - real(kind(0d0)), intent(in) :: a, b - real(kind(0d0)), intent(out) :: c + real(wp), intent(in) :: a, b + real(wp), intent(out) :: c ! ! finds dsqrt(a**2+b**2) without overflow or destructive underflow ! - real(kind(0d0)) :: p, r, s, t, u + real(wp) :: p, r, s, t, u p = dmax1(dabs(a), dabs(b)) - if (p == 0.0d0) go to 20 + if (p == 0.0_wp) go to 20 r = (dmin1(dabs(a), dabs(b))/p)**2 10 continue - t = 4.0d0 + r - if (t == 4.0d0) go to 20 + t = 4.0_wp + r + if (t == 4.0_wp) go to 20 s = r/t - u = 1.0d0 + 2.0d0*s + u = 1.0_wp + 2.0_wp*s p = u*p - r = (s/u)**2d0*r + r = (s/u)**2._wp*r go to 10 20 c = p return diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index fc26005fd8..31bd9753d0 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -46,30 +46,30 @@ contains !! @param ntmp is the output number bubble density subroutine s_comp_n_from_prim(vftmp, Rtmp, ntmp, weights) !$acc routine seq - real(kind(0.d0)), intent(in) :: vftmp - real(kind(0.d0)), dimension(nb), intent(in) :: Rtmp - real(kind(0.d0)), intent(out) :: ntmp - real(kind(0.d0)), dimension(nb), intent(in) :: weights + real(kind(0._wp)), intent(in) :: vftmp + real(kind(0._wp)), dimension(nb), intent(in) :: Rtmp + real(kind(0._wp)), intent(out) :: ntmp + real(kind(0._wp)), dimension(nb), intent(in) :: weights - real(kind(0.d0)) :: R3 + real(kind(0._wp)) :: R3 - R3 = dot_product(weights, Rtmp**3.d0) - ntmp = (3.d0/(4.d0*pi))*vftmp/R3 + R3 = dot_product(weights, Rtmp**3._wp) + ntmp = (3._wp/(4._wp*pi))*vftmp/R3 end subroutine s_comp_n_from_prim subroutine s_comp_n_from_cons(vftmp, nRtmp, ntmp, weights) !$acc routine seq - real(kind(0.d0)), intent(in) :: vftmp - real(kind(0.d0)), dimension(nb), intent(in) :: nRtmp - real(kind(0.d0)), intent(out) :: ntmp - real(kind(0.d0)), dimension(nb), intent(in) :: weights + real(kind(0._wp)), intent(in) :: vftmp + real(kind(0._wp)), dimension(nb), intent(in) :: nRtmp + real(kind(0._wp)), intent(out) :: ntmp + real(kind(0._wp)), dimension(nb), intent(in) :: weights - real(kind(0.d0)) :: nR3 + real(kind(0._wp)) :: nR3 - nR3 = dot_product(weights, nRtmp**3.d0) - ntmp = DSQRT((4.d0*pi/3.d0)*nR3/vftmp) - !ntmp = (3.d0/(4.d0*pi))*0.00001 + nR3 = dot_product(weights, nRtmp**3._wp) + ntmp = DSQRT((4._wp*pi/3._wp)*nR3/vftmp) + !ntmp = (3._wp/(4._wp*pi))*0.00001 !print *, "nbub", ntmp @@ -77,7 +77,7 @@ contains subroutine s_print_2D_array(A, div) - real(kind(0d0)), dimension(:, :), intent(in) :: A + real(wp), dimension(:, :), intent(in) :: A real, optional, intent(in) :: div integer :: i, j @@ -109,13 +109,13 @@ contains subroutine s_initialize_nonpoly integer :: ir - real(kind(0.d0)) :: rhol0, pl0, uu, D_m, temp, omega_ref - real(kind(0.d0)), dimension(Nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw + real(kind(0._wp)) :: rhol0, pl0, uu, D_m, temp, omega_ref + real(kind(0._wp)), dimension(Nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw - real(kind(0.d0)), parameter :: k_poly = 1.d0 !< + real(kind(0._wp)), parameter :: k_poly = 1._wp !< !! polytropic index used to compute isothermal natural frequency - real(kind(0.d0)), parameter :: Ru = 8314.d0 !< + real(kind(0._wp)), parameter :: Ru = 8314._wp !< !! universal gas constant rhol0 = rhoref @@ -150,42 +150,42 @@ contains k_n(:) = fluid_pp(2)%k_v gamma_m = gamma_n - if (thermal == 2) gamma_m = 1.d0 + if (thermal == 2) gamma_m = 1._wp - temp = 293.15d0 + temp = 293.15_wp D_m = 0.242d-4 uu = DSQRT(pl0/rhol0) - omega_ref = 3.d0*k_poly*Ca + 2.d0*(3.d0*k_poly - 1.d0)/Web + omega_ref = 3._wp*k_poly*Ca + 2._wp*(3._wp*k_poly - 1._wp)/Web !!! thermal properties !!! ! gas constants R_n = Ru/M_n R_v = Ru/M_v ! phi_vn & phi_nv (phi_nn = phi_vv = 1) - phi_vn = (1.d0 + DSQRT(mu_v/mu_n)*(M_n/M_v)**(0.25d0))**2 & - /(DSQRT(8.d0)*DSQRT(1.d0 + M_v/M_n)) - phi_nv = (1.d0 + DSQRT(mu_n/mu_v)*(M_v/M_n)**(0.25d0))**2 & - /(DSQRT(8.d0)*DSQRT(1.d0 + M_n/M_v)) + phi_vn = (1._wp + DSQRT(mu_v/mu_n)*(M_n/M_v)**(0.25_wp))**2 & + /(DSQRT(8._wp)*DSQRT(1._wp + M_v/M_n)) + phi_nv = (1._wp + DSQRT(mu_n/mu_v)*(M_v/M_n)**(0.25_wp))**2 & + /(DSQRT(8._wp)*DSQRT(1._wp + M_n/M_v)) ! internal bubble pressure - pb0 = pl0 + 2.d0*ss/(R0ref*R0) + pb0 = pl0 + 2._wp*ss/(R0ref*R0) ! mass fraction of vapor - chi_vw0 = 1.d0/(1.d0 + R_v/R_n*(pb0/pv - 1.d0)) + chi_vw0 = 1._wp/(1._wp + R_v/R_n*(pb0/pv - 1._wp)) ! specific heat for gas/vapor mixture - cp_m0 = chi_vw0*R_v*gamma_v/(gamma_v - 1.d0) & - + (1.d0 - chi_vw0)*R_n*gamma_n/(gamma_n - 1.d0) + cp_m0 = chi_vw0*R_v*gamma_v/(gamma_v - 1._wp) & + + (1._wp - chi_vw0)*R_n*gamma_n/(gamma_n - 1._wp) ! mole fraction of vapor x_vw = M_n*chi_vw0/(M_v + (M_n - M_v)*chi_vw0) ! thermal conductivity for gas/vapor mixture - k_m0 = x_vw*k_v/(x_vw + (1.d0 - x_vw)*phi_vn) & - + (1.d0 - x_vw)*k_n/(x_vw*phi_nv + 1.d0 - x_vw) + k_m0 = x_vw*k_v/(x_vw + (1._wp - x_vw)*phi_vn) & + + (1._wp - x_vw)*k_n/(x_vw*phi_nv + 1._wp - x_vw) ! mixture density rho_m0 = pv/(chi_vw0*R_v*temp) ! mass of gas/vapor computed using dimensional quantities - mass_n0 = 4.d0*(pb0 - pv)*pi/(3.d0*R_n*temp*rhol0)*R0**3 - mass_v0 = 4.d0*pv*pi/(3.d0*R_v*temp*rhol0)*R0**3 + mass_n0 = 4._wp*(pb0 - pv)*pi/(3._wp*R_n*temp*rhol0)*R0**3 + mass_v0 = 4._wp*pv*pi/(3._wp*R_v*temp*rhol0)*R0**3 ! Peclet numbers Pe_T = rho_m0*cp_m0*uu*R0ref/k_m0 Pe_c = uu*R0ref/D_m @@ -200,22 +200,22 @@ contains k_v = k_v/k_m0 pb0 = pb0/pl0 pv = pv/pl0 - Tw = 1.d0 - pl0 = 1.d0 + Tw = 1._wp + pl0 = 1._wp - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp !end if ! natural frequencies - omegaN = DSQRT(3.d0*k_poly*Ca + 2.d0*(3.d0*k_poly - 1.d0)/(Web*R0))/R0 + omegaN = DSQRT(3._wp*k_poly*Ca + 2._wp*(3._wp*k_poly - 1._wp)/(Web*R0))/R0 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)) end do - Im_trans_T = 0d0 + Im_trans_T = 0._wp end subroutine s_initialize_nonpoly @@ -226,17 +226,17 @@ contains !! @param Im_trans Imaginary part of the transport coefficients subroutine s_transcoeff(omega, peclet, Re_trans, Im_trans) - real(kind(0.d0)), intent(in) :: omega, peclet - real(kind(0.d0)), intent(out) :: Re_trans, Im_trans + real(kind(0._wp)), intent(in) :: omega, peclet + real(kind(0._wp)), intent(out) :: Re_trans, Im_trans complex :: trans, c1, c2, c3 complex :: imag = (0., 1.) - real(kind(0.d0)) :: f_transcoeff + real(kind(0._wp)) :: f_transcoeff c1 = imag*omega*peclet c2 = CSQRT(c1) c3 = (CEXP(c2) - CEXP(-c2))/(CEXP(c2) + CEXP(-c2)) ! TANH(c2) - trans = ((c2/c3 - 1.d0)**(-1) - 3.d0/c1)**(-1) ! transfer function + trans = ((c2/c3 - 1._wp)**(-1) - 3._wp/c1)**(-1) ! transfer function Re_trans = dble(trans) Im_trans = aimag(trans) @@ -256,8 +256,8 @@ contains subroutine s_simpson integer :: ir - real(kind(0.d0)) :: R0mn, R0mx, dphi, tmp, sd - real(kind(0.d0)), dimension(nb) :: phi + real(kind(0._wp)) :: R0mn, R0mx, dphi, tmp, sd + real(kind(0._wp)), dimension(nb) :: phi ! nondiml. min. & max. initial radii for numerical quadrature !sd = 0.05D0 @@ -273,8 +273,8 @@ contains !R0mx = 150.D0 sd = poly_sigma - R0mn = 0.8d0*DEXP(-2.8d0*sd) - R0mx = 0.2d0*DEXP(9.5d0*sd) + 1.d0 + R0mn = 0.8_wp*DEXP(-2.8_wp*sd) + R0mx = 0.2_wp*DEXP(9.5_wp*sd) + 1._wp ! phi = ln( R0 ) & return R0 do ir = 1, nb @@ -287,17 +287,17 @@ contains ! weights for quadrature using Simpson's rule do ir = 2, nb - 1 ! Gaussian - tmp = DEXP(-0.5d0*(phi(ir)/sd)**2)/DSQRT(2.d0*pi)/sd + tmp = DEXP(-0.5_wp*(phi(ir)/sd)**2)/DSQRT(2._wp*pi)/sd if (mod(ir, 2) == 0) then - weight(ir) = tmp*4.d0*dphi/3.d0 + weight(ir) = tmp*4._wp*dphi/3._wp else - weight(ir) = tmp*2.d0*dphi/3.d0 + weight(ir) = tmp*2._wp*dphi/3._wp end if end do - tmp = DEXP(-0.5d0*(phi(1)/sd)**2)/DSQRT(2.d0*pi)/sd - weight(1) = tmp*dphi/3.d0 - tmp = DEXP(-0.5d0*(phi(nb)/sd)**2)/DSQRT(2.d0*pi)/sd - weight(nb) = tmp*dphi/3.d0 + tmp = DEXP(-0.5_wp*(phi(1)/sd)**2)/DSQRT(2._wp*pi)/sd + weight(1) = tmp*dphi/3._wp + tmp = DEXP(-0.5_wp*(phi(nb)/sd)**2)/DSQRT(2._wp*pi)/sd + weight(nb) = tmp*dphi/3._wp end subroutine s_simpson !> This procedure computes the cross product of two vectors. @@ -306,8 +306,8 @@ contains !! @return The cross product of the two vectors. function f_cross(a, b) result(c) - real(kind(0d0)), dimension(3), intent(in) :: a, b - real(kind(0d0)), dimension(3) :: c + real(wp), dimension(3), intent(in) :: a, b + 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) @@ -319,8 +319,8 @@ contains !! @param rhs Right-hand side. subroutine s_swap(lhs, rhs) - real(kind(0d0)), intent(inout) :: lhs, rhs - real(kind(0d0)) :: ltemp + real(wp), intent(inout) :: lhs, rhs + real(wp) :: ltemp ltemp = lhs lhs = rhs @@ -336,34 +336,34 @@ contains t_mat4x4 :: sc, rz, rx, ry, tr, out_matrix sc = transpose(reshape([ & - p%scale(1), 0d0, 0d0, 0d0, & - 0d0, p%scale(2), 0d0, 0d0, & - 0d0, 0d0, p%scale(3), 0d0, & - 0d0, 0d0, 0d0, 1d0], shape(sc))) + p%scale(1), 0._wp, 0._wp, 0._wp, & + 0._wp, p%scale(2), 0._wp, 0._wp, & + 0._wp, 0._wp, p%scale(3), 0._wp, & + 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) rz = transpose(reshape([ & - cos(p%rotate(3)), -sin(p%rotate(3)), 0d0, 0d0, & - sin(p%rotate(3)), cos(p%rotate(3)), 0d0, 0d0, & - 0d0, 0d0, 1d0, 0d0, & - 0d0, 0d0, 0d0, 1d0], shape(rz))) + cos(p%rotate(3)), -sin(p%rotate(3)), 0._wp, 0._wp, & + sin(p%rotate(3)), cos(p%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([ & - 1d0, 0d0, 0d0, 0d0, & - 0d0, cos(p%rotate(1)), -sin(p%rotate(1)), 0d0, & - 0d0, sin(p%rotate(1)), cos(p%rotate(1)), 0d0, & - 0d0, 0d0, 0d0, 1d0], shape(rx))) + 1._wp, 0._wp, 0._wp, 0._wp, & + 0._wp, cos(p%rotate(1)), -sin(p%rotate(1)), 0._wp, & + 0._wp, sin(p%rotate(1)), cos(p%rotate(1)), 0._wp, & + 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) ry = transpose(reshape([ & - cos(p%rotate(2)), 0d0, sin(p%rotate(2)), 0d0, & - 0d0, 1d0, 0d0, 0d0, & - -sin(p%rotate(2)), 0d0, cos(p%rotate(2)), 0d0, & - 0d0, 0d0, 0d0, 1d0], shape(ry))) + cos(p%rotate(2)), 0._wp, sin(p%rotate(2)), 0._wp, & + 0._wp, 1._wp, 0._wp, 0._wp, & + -sin(p%rotate(2)), 0._wp, cos(p%rotate(2)), 0._wp, & + 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) tr = transpose(reshape([ & - 1d0, 0d0, 0d0, p%translate(1), & - 0d0, 1d0, 0d0, p%translate(2), & - 0d0, 0d0, 1d0, p%translate(3), & - 0d0, 0d0, 0d0, 1d0], shape(tr))) + 1._wp, 0._wp, 0._wp, p%translate(1), & + 0._wp, 1._wp, 0._wp, p%translate(2), & + 0._wp, 0._wp, 1._wp, p%translate(3), & + 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) out_matrix = matmul(tr, matmul(ry, matmul(rx, matmul(rz, sc)))) @@ -377,9 +377,9 @@ contains t_vec3, intent(inout) :: vec t_mat4x4, intent(in) :: matrix - real(kind(0d0)), dimension(1:4) :: tmp + real(wp), dimension(1:4) :: tmp - tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1d0]) + tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1._wp]) vec = tmp(1:3) end subroutine s_transform_vec @@ -394,7 +394,7 @@ contains integer :: i - real(kind(0d0)), dimension(1:4) :: tmp + real(wp), dimension(1:4) :: tmp do i = 1, 3 call s_transform_vec(triangle%v(i, :), matrix) @@ -429,8 +429,8 @@ contains integer :: i, j if (size(model%trs) == 0) then - bbox%min = 0d0 - bbox%max = 0d0 + bbox%min = 0._wp + bbox%max = 0._wp return end if diff --git a/src/common/m_helper_basic.f90 b/src/common/m_helper_basic.f90 index 0611ff86f5..b5483998bb 100644 --- a/src/common/m_helper_basic.f90 +++ b/src/common/m_helper_basic.f90 @@ -19,7 +19,7 @@ module m_helper_basic contains - !> This procedure checks if two floating point numbers of kind(0d0) are within tolerance. + !> This procedure checks if two floating point numbers of wp are within tolerance. !! @param a First number. !! @param b Second number. !! @param tol_input Relative error (default = 1d-6). @@ -28,9 +28,9 @@ logical function f_approx_equal(a, b, tol_input) result(res) !$acc routine seq ! Reference: https://floating-point-gui.de/errors/comparison/ - real(kind(0d0)), intent(in) :: a, b - real(kind(0d0)), optional, intent(in) :: tol_input - real(kind(0d0)) :: tol + real(wp), intent(in) :: a, b + real(wp), optional, intent(in) :: tol_input + real(wp) :: tol if (present(tol_input)) then tol = tol_input @@ -40,26 +40,26 @@ logical function f_approx_equal(a, b, tol_input) result(res) if (a == b) then res = .true. - else if (a == 0d0 .or. b == 0d0 .or. (abs(a) + abs(b) < tiny(a))) then + else if (a == 0._wp .or. b == 0._wp .or. (abs(a) + abs(b) < tiny(a))) then res = (abs(a - b) < (tol*tiny(a))) else res = (abs(a - b)/min(abs(a) + abs(b), huge(a)) < tol) end if end function f_approx_equal - !> Checks if a real(kind(0d0)) variable is of default value. + !> Checks if a real(wp) variable is of default value. !! @param var Variable to check. logical function f_is_default(var) result(res) !$acc routine seq - real(kind(0d0)), intent(in) :: var + real(wp), intent(in) :: var res = f_approx_equal(var, dflt_real) end function f_is_default - !> Checks if ALL elements of a real(kind(0d0)) array are of default value. + !> 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(kind(0d0)), intent(in) :: var_array(:) + real(wp), intent(in) :: var_array(:) logical :: res_array(size(var_array)) integer :: i @@ -70,13 +70,13 @@ logical function f_all_default(var_array) result(res) res = all(res_array) end function f_all_default - !> Checks if a real(kind(0d0)) variable is an integer. + !> Checks if a real(wp) variable is an integer. !! @param var Variable to check. logical function f_is_integer(var) result(res) !$acc routine seq - real(kind(0d0)), intent(in) :: var + real(wp), intent(in) :: var - res = f_approx_equal(var, real(nint(var), kind(0d0))) + res = f_approx_equal(var, real(nint(var), wp)) end function f_is_integer end module m_helper_basic diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 78fe8df374..28da5fcee8 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -118,7 +118,7 @@ contains ! Define the view for each variable do i = 1, sys_size call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), ierr) + MPI_ORDER_FORTRAN, mpi_p, MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do @@ -126,7 +126,7 @@ contains if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*4 call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), ierr) + MPI_ORDER_FORTRAN, mpi_p, MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do @@ -167,7 +167,7 @@ contains #endif call MPI_TYPE_CREATE_SUBARRAY(1, airfoil_glb, airfoil_loc, airfoil_start, & - MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(1), ierr) + MPI_ORDER_FORTRAN, mpi_p, MPI_IO_airfoil_IB_DATA%view(1), ierr) call MPI_TYPE_COMMIT(MPI_IO_airfoil_IB_DATA%view(1), ierr) #ifdef MFC_PRE_PROCESS @@ -177,7 +177,7 @@ contains end do #endif call MPI_TYPE_CREATE_SUBARRAY(1, airfoil_glb, airfoil_loc, airfoil_start, & - MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(2), ierr) + MPI_ORDER_FORTRAN, mpi_p, MPI_IO_airfoil_IB_DATA%view(2), ierr) call MPI_TYPE_COMMIT(MPI_IO_airfoil_IB_DATA%view(2), ierr) end if @@ -192,12 +192,12 @@ contains subroutine mpi_bcast_time_step_values(proc_time, time_avg) - real(kind(0d0)), dimension(0:num_procs - 1), intent(inout) :: proc_time - real(kind(0d0)), intent(inout) :: time_avg + real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time + real(wp), intent(inout) :: time_avg #ifdef MFC_MPI - call MPI_GATHER(time_avg, 1, MPI_DOUBLE_PRECISION, proc_time(0), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif @@ -226,15 +226,15 @@ contains ccfl_max_glb, & Rc_min_glb) - real(kind(0d0)), intent(in) :: icfl_max_loc - real(kind(0d0)), intent(in) :: vcfl_max_loc - real(kind(0d0)), intent(in) :: ccfl_max_loc - real(kind(0d0)), intent(in) :: Rc_min_loc + real(wp), intent(in) :: icfl_max_loc + real(wp), intent(in) :: vcfl_max_loc + real(wp), intent(in) :: ccfl_max_loc + real(wp), intent(in) :: Rc_min_loc - real(kind(0d0)), intent(out) :: icfl_max_glb - real(kind(0d0)), intent(out) :: vcfl_max_glb - real(kind(0d0)), intent(out) :: ccfl_max_glb - real(kind(0d0)), intent(out) :: Rc_min_glb + real(wp), intent(out) :: icfl_max_glb + real(wp), intent(out) :: vcfl_max_glb + real(wp), intent(out) :: ccfl_max_glb + real(wp), intent(out) :: Rc_min_glb #ifdef MFC_MPI #ifdef MFC_SIMULATION @@ -242,15 +242,15 @@ contains ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their ! global extrema and bookkeeping the results on the rank 0 processor call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, & - MPI_DOUBLE_PRECISION, MPI_MAX, 0, & + mpi_p, MPI_MAX, 0, & MPI_COMM_WORLD, ierr) if (any(Re_size > 0)) then call MPI_REDUCE(vcfl_max_loc, vcfl_max_glb, 1, & - MPI_DOUBLE_PRECISION, MPI_MAX, 0, & + mpi_p, MPI_MAX, 0, & MPI_COMM_WORLD, ierr) call MPI_REDUCE(Rc_min_loc, Rc_min_glb, 1, & - MPI_DOUBLE_PRECISION, MPI_MIN, 0, & + mpi_p, MPI_MIN, 0, & MPI_COMM_WORLD, ierr) end if @@ -268,13 +268,13 @@ contains !! @param var_glb The globally reduced value subroutine s_mpi_allreduce_sum(var_loc, var_glb) - real(kind(0d0)), intent(in) :: var_loc - real(kind(0d0)), intent(out) :: var_glb + real(wp), intent(in) :: var_loc + real(wp), intent(out) :: var_glb #ifdef MFC_MPI ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_DOUBLE_PRECISION, & + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & MPI_SUM, MPI_COMM_WORLD, ierr) #endif @@ -290,13 +290,13 @@ contains !! @param var_glb The globally reduced value subroutine s_mpi_allreduce_min(var_loc, var_glb) - real(kind(0d0)), intent(in) :: var_loc - real(kind(0d0)), intent(out) :: var_glb + real(wp), intent(in) :: var_loc + real(wp), intent(out) :: var_glb #ifdef MFC_MPI ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_DOUBLE_PRECISION, & + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & MPI_MIN, MPI_COMM_WORLD, ierr) #endif @@ -312,13 +312,13 @@ contains !! @param var_glb The globally reduced value subroutine s_mpi_allreduce_max(var_loc, var_glb) - real(kind(0d0)), intent(in) :: var_loc - real(kind(0d0)), intent(out) :: var_glb + real(wp), intent(in) :: var_loc + real(wp), intent(out) :: var_glb #ifdef MFC_MPI ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_DOUBLE_PRECISION, & + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & MPI_MAX, MPI_COMM_WORLD, ierr) #endif @@ -333,19 +333,19 @@ contains !! the minimum value, reduced amongst all of the local values. subroutine s_mpi_reduce_min(var_loc) - real(kind(0d0)), intent(inout) :: var_loc + real(wp), intent(inout) :: var_loc #ifdef MFC_MPI ! Temporary storage variable that holds the reduced minimum value - real(kind(0d0)) :: var_glb + 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_DOUBLE_PRECISION, & + call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, & MPI_MIN, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(var_glb, 1, MPI_DOUBLE_PRECISION, & + call MPI_BCAST(var_glb, 1, mpi_p, & 0, MPI_COMM_WORLD, ierr) var_loc = var_glb @@ -368,11 +368,11 @@ contains !! belongs. subroutine s_mpi_reduce_maxloc(var_loc) - real(kind(0d0)), dimension(2), intent(inout) :: var_loc + real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - real(kind(0d0)), dimension(2) :: var_glb !< + 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 diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index f637232288..9264a14b62 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -52,16 +52,16 @@ module m_phase_change !> @name Parameters for the first order transition phase change !> @{ integer, parameter :: max_iter = 1e8 !< max # of iterations - real(kind(0d0)), parameter :: pCr = 4.94d7 !< Critical water pressure - real(kind(0d0)), parameter :: TCr = 385.05 + 273.15 !< Critical water temperature - real(kind(0d0)), parameter :: mixM = 1.0d-8 !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen + real(wp), parameter :: pCr = 4.94d7 !< Critical water pressure + real(wp), parameter :: TCr = 385.05 + 273.15 !< Critical water temperature + real(wp), parameter :: mixM = 1.0d-8 !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters !> @{ - real(kind(0d0)) :: A, B, C, D + real(wp) :: A, B, C, D !> @} !$acc declare create(max_iter,pCr,TCr,mixM,lp,vp,A,B,C,D) @@ -77,15 +77,15 @@ contains 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.0d0)*cvs(vp)) + + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) - B = (qvs(lp) - qvs(vp))/((gs_min(vp) - 1.0d0)*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.0d0)*cvs(vp)) + /((gs_min(vp) - 1.0_wp)*cvs(vp)) - D = ((gs_min(lp) - 1.0d0)*cvs(lp)) & - /((gs_min(vp) - 1.0d0)*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 @@ -97,15 +97,15 @@ contains subroutine s_infinite_relaxation_k(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(kind(0.0d0)) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid - real(kind(0.0d0)) :: TS, TSOV, TSSL, TSatOV, TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid - real(kind(0.0d0)) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy - real(kind(0.0d0)) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses - real(kind(0.0d0)) :: TvF !< total volume fraction + real(kind(0.0_wp)) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid + real(kind(0.0_wp)) :: TS, TSOV, TSSL, TSatOV, TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid + real(kind(0.0_wp)) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy + real(kind(0.0_wp)) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses + real(kind(0.0_wp)) :: TvF !< total volume fraction !$acc declare create(pS, pSOV, pSSL, TS, TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF) - real(kind(0d0)), dimension(num_fluids) :: p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok + real(wp), dimension(num_fluids) :: p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok !< Generic loop iterators integer :: i, j, k, l @@ -118,7 +118,7 @@ contains do k = 0, n do l = 0, p - rho = 0.0d0; TvF = 0.0d0 + rho = 0.0_wp; TvF = 0.0_wp !$acc loop seq do i = 1, num_fluids @@ -144,7 +144,7 @@ contains m2 = q_cons_vf(vp + contxb - 1)%sf(j, k, l) ! kinetic energy as an auxiliary variable to the calculation of the total internal energy - dynE = 0.0d0 + dynE = 0.0_wp !$acc loop seq do i = momxb, momxe @@ -177,7 +177,7 @@ contains q_cons_vf(lp + contxb - 1)%sf(j, k, l) = mixM*rM ! tranferring the total mass to vapor - q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0d0 - mixM)*rM + q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM ! calling pT-equilibrium for overheated vapor, which is MFL = 0 call s_infinite_pt_relaxation_k(j, k, l, 0, pSOV, p_infOV, rM, q_cons_vf, rhoe, TSOV) @@ -187,7 +187,7 @@ contains ! subcooled liquid case ! tranferring the total mass to liquid - q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0d0 - mixM)*rM + q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM ! depleting the mass of vapor q_cons_vf(vp + contxb - 1)%sf(j, k, l) = mixM*rM @@ -211,7 +211,7 @@ contains q_cons_vf(lp + contxb - 1)%sf(j, k, l) = mixM*rM ! correcting the vapor partial density - q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0d0 - mixM)*rM + q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM elseif (TSSL < TSatSL) then @@ -222,7 +222,7 @@ contains TS = TSSL ! correcting the liquid partial density - q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0d0 - mixM)*rM + q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM ! correcting the vapor partial density q_cons_vf(vp + contxb - 1)%sf(j, k, l) = mixM*rM @@ -247,7 +247,7 @@ contains ! entropy sk(1:num_fluids) = cvs(1:num_fluids)*DLOG((TS**gs_min(1:num_fluids)) & - /((pS + ps_inf(1:num_fluids))**(gs_min(1:num_fluids) - 1.0d0))) + qvps(1:num_fluids) + /((pS + ps_inf(1:num_fluids))**(gs_min(1:num_fluids) - 1.0_wp))) + qvps(1:num_fluids) ! enthalpy hk(1:num_fluids) = gs_min(1:num_fluids)*cvs(1:num_fluids)*TS & @@ -266,7 +266,7 @@ contains *cvs(1:num_fluids)*TS + qvs(1:num_fluids) ! calculating volume fractions, internal energies, and total entropy - rhos = 0.0d0 + rhos = 0.0_wp !$acc loop seq do i = 1, num_fluids @@ -302,21 +302,21 @@ contains ! initializing variables integer, intent(in) :: j, k, l, MFL - real(kind(0.0d0)), intent(out) :: pS - real(kind(0.0d0)), dimension(num_fluids), intent(out) :: p_infpT - real(kind(0.0d0)), intent(in) :: rM + real(kind(0.0_wp)), intent(out) :: pS + real(kind(0.0_wp)), dimension(num_fluids), intent(out) :: p_infpT + real(kind(0.0_wp)), intent(in) :: rM type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(kind(0.0d0)), intent(in) :: rhoe - real(kind(0.0d0)), intent(out) :: TS + real(kind(0.0_wp)), intent(in) :: rhoe + real(kind(0.0_wp)), intent(out) :: TS integer, dimension(num_fluids) :: ig !< flags to toggle the inclusion of fluids for the pT-equilibrium - real(kind(0.0d0)), dimension(num_fluids) :: pk !< individual initial pressures - real(kind(0.0d0)) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver + real(kind(0.0_wp)), dimension(num_fluids) :: pk !< individual initial pressures + real(kind(0.0_wp)) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver integer :: i, ns !< generic loop iterators ! auxiliary variables for the pT-equilibrium solver - mCP = 0.0d0; mQ = 0.0d0; p_infpT = ps_inf; + mCP = 0.0_wp; mQ = 0.0_wp; p_infpT = ps_inf; ! Performing tests before initializing the pT-equilibrium !$acc loop seq do i = 1, num_fluids @@ -330,16 +330,16 @@ contains end do ! Checking energy constraint - if ((rhoe - mQ - minval(p_infpT)) < 0.0d0) then + if ((rhoe - mQ - minval(p_infpT)) < 0.0_wp) then if ((MFL == 0) .or. (MFL == 1)) then ! Assigning zero values for mass depletion cases ! pressure - pS = 0.0d0 + pS = 0.0_wp ! temperature - TS = 0.0d0 + TS = 0.0_wp return end if @@ -348,7 +348,7 @@ contains ! 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.0d0 + 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. @@ -366,23 +366,23 @@ contains pO = pS ! updating functions used in the Newton's solver - gpp = 0.0d0; gp = 0.0d0; hp = 0.0d0 + gpp = 0.0_wp; gp = 0.0_wp; hp = 0.0_wp !$acc loop seq do i = 1, num_fluids - gp = gp + (gs_min(i) - 1.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(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.0d0)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(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) end do - hp = 1.0d0/(rhoe + pS - mQ) + 1.0d0/(pS + minval(p_infpT)) + hp = 1.0_wp/(rhoe + pS - mQ) + 1.0_wp/(pS + minval(p_infpT)) ! updating common pressure for the newton solver - pS = pO + ((1.0d0 - gp)/gpp)/(1.0d0 - (1.0d0 - gp + DABS(1.0d0 - gp)) & - /(2.0d0*gpp)*hp) + pS = pO + ((1.0_wp - gp)/gpp)/(1.0_wp - (1.0_wp - gp + DABS(1.0_wp - gp)) & + /(2.0_wp*gpp)*hp) end do ! common temperature @@ -405,17 +405,17 @@ contains !$acc routine seq integer, intent(in) :: j, k, l - real(kind(0.0d0)), intent(inout) :: pS - real(kind(0.0d0)), dimension(num_fluids), intent(in) :: p_infpT - real(kind(0.0d0)), intent(in) :: rhoe + real(kind(0.0_wp)), intent(inout) :: pS + real(kind(0.0_wp)), dimension(num_fluids), intent(in) :: p_infpT + real(kind(0.0_wp)), intent(in) :: rhoe type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(kind(0.0d0)), intent(inout) :: TS + real(kind(0.0_wp)), intent(inout) :: TS - real(kind(0.0d0)), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium - real(kind(0.0d0)), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver - real(kind(0.0d0)), dimension(2) :: R2D, DeltamP !< residual and correction array - real(kind(0.0d0)) :: Om ! underrelaxation factor - real(kind(0.0d0)) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver + real(kind(0.0_wp)), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium + real(kind(0.0_wp)), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver + real(kind(0.0_wp)), dimension(2) :: R2D, DeltamP !< residual and correction array + real(kind(0.0_wp)) :: Om ! underrelaxation factor + real(kind(0.0_wp)) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver !< Generic loop iterators integer :: i, ns @@ -429,10 +429,10 @@ contains p_infpTg = p_infpT - if (((pS < 0.0d0) .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.0d0) .and. (pS < 1.0d-1))) 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.0d-1))) then ! improve this initial condition pS = 1.0d4 @@ -444,8 +444,8 @@ contains ! for the residual, and how to do it adequately. ! Dummy guess to start the pTg-equilibrium problem. ! improve this initial condition - R2D(1) = 0.0d0; R2D(2) = 0.0d0 - DeltamP(1) = 0.0d0; DeltamP(2) = 0.0d0 + R2D(1) = 0.0_wp; R2D(2) = 0.0_wp + DeltamP(1) = 0.0_wp; DeltamP(2) = 0.0_wp do while (((DSQRT(R2D(1)**2 + R2D(2)**2) > ptgalpha_eps) & .and. ((DSQRT(R2D(1)**2 + R2D(2)**2)/rhoe) > (ptgalpha_eps/1d6))) & .or. (ns == 0)) @@ -454,7 +454,7 @@ contains ns = ns + 1 ! Auxiliary variables to help in the calculation of the residue - mCP = 0.0d0; mCPD = 0.0d0; mCVGP = 0.0d0; mCVGP2 = 0.0d0; mQ = 0.0d0; mQD = 0.0d0 + 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 !$acc loop seq @@ -491,7 +491,7 @@ contains call s_compute_jacobian_matrix(InvJac, j, Jac, k, l, mCPD, mCVGP, mCVGP2, pS, q_cons_vf, TJac) ! calculating correction array for Newton's method - DeltamP = -1.0d0*matmul(InvJac, R2D) + DeltamP = -1.0_wp*matmul(InvJac, R2D) ! updating two reacting 'masses'. Recall that inert 'masses' do not change during the phase change ! liquid @@ -526,19 +526,19 @@ contains !> @name variables for the correction of the reacting partial densities !> @{ - real(kind(0.0d0)), intent(out) :: MCT + real(kind(0.0_wp)), intent(out) :: MCT type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(kind(0.0d0)), intent(inout) :: rM + real(kind(0.0_wp)), intent(inout) :: rM integer, intent(in) :: j, k, l !> @} - if (rM < 0.0d0) then + if (rM < 0.0_wp) then - if ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) >= -1.0d0*mixM) .and. & - (q_cons_vf(vp + contxb - 1)%sf(j, k, l) >= -1.0d0*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.0d0 + q_cons_vf(lp + contxb - 1)%sf(j, k, l) = 0.0_wp - q_cons_vf(vp + contxb - 1)%sf(j, k, l) = 0.0d0 + 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) @@ -551,15 +551,15 @@ contains 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.0d0) then + 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.0d0 - 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.0d0) then + elseif (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.0d0 - MCT)*rM + 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 @@ -582,15 +582,15 @@ contains subroutine s_compute_jacobian_matrix(InvJac, j, Jac, k, l, mCPD, mCVGP, mCVGP2, pS, q_cons_vf, TJac) !$acc routine seq - real(kind(0.0d0)), dimension(2, 2), intent(out) :: InvJac + real(kind(0.0_wp)), dimension(2, 2), intent(out) :: InvJac integer, intent(in) :: j - real(kind(0.0d0)), dimension(2, 2), intent(out) :: Jac + real(kind(0.0_wp)), dimension(2, 2), intent(out) :: Jac integer, intent(in) :: k, l - real(kind(0.0d0)), intent(in) :: mCPD, mCVGP, mCVGP2, pS + real(kind(0.0_wp)), intent(in) :: mCPD, mCVGP, mCVGP2, pS type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(kind(0.0d0)), dimension(2, 2), intent(out) :: TJac + real(kind(0.0_wp)), dimension(2, 2), intent(out) :: TJac - real(kind(0.0d0)) :: ml, mT, TS, dFdT, dTdm, dTdp ! mass of the reacting fluid, total reacting mass, and auxiliary variables + real(kind(0.0_wp)) :: ml, mT, TS, dFdT, dTdm, dTdp ! mass of the reacting fluid, total reacting mass, and auxiliary variables ! mass of the reacting liquid ml = q_cons_vf(lp + contxb - 1)%sf(j, k, l) @@ -655,8 +655,8 @@ contains ! intermediate elements of J^{-1} InvJac(1, 1) = Jac(2, 2) - InvJac(1, 2) = -1.0d0*Jac(1, 2) - InvJac(2, 1) = -1.0d0*Jac(2, 1) + InvJac(1, 2) = -1.0_wp*Jac(1, 2) + InvJac(2, 1) = -1.0_wp*Jac(2, 1) InvJac(2, 2) = Jac(1, 1) ! elements of J^{T} @@ -685,12 +685,12 @@ contains !$acc routine seq integer, intent(in) :: j, k, l - real(kind(0.0d0)), intent(in) :: mCPD, mCVGP, mQD + real(kind(0.0_wp)), intent(in) :: mCPD, mCVGP, mQD type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(kind(0.0d0)), intent(in) :: pS, rhoe - real(kind(0.0d0)), dimension(2), intent(out) :: R2D + real(kind(0.0_wp)), intent(in) :: pS, rhoe + real(kind(0.0_wp)), dimension(2), intent(out) :: R2D - real(kind(0.0d0)) :: ml, mT, TS !< mass of the reacting liquid, total reacting mass, equilibrium temperature + real(kind(0.0_wp)) :: ml, mT, TS !< mass of the reacting liquid, total reacting mass, equilibrium temperature ! mass of the reacting liquid ml = q_cons_vf(lp + contxb - 1)%sf(j, k, l) @@ -730,19 +730,19 @@ contains subroutine s_TSat(pSat, TSat, TSIn) !$acc routine seq - real(kind(0.0d0)), intent(in) :: pSat - real(kind(0.0d0)), intent(out) :: TSat - real(kind(0.0d0)), intent(in) :: TSIn + real(kind(0.0_wp)), intent(in) :: pSat + real(kind(0.0_wp)), intent(out) :: TSat + real(kind(0.0_wp)), intent(in) :: TSIn - real(kind(0.0d0)) :: dFdT, FT, Om !< auxiliary variables + real(kind(0.0_wp)) :: dFdT, FT, Om !< auxiliary variables ! Generic loop iterators integer :: ns - if ((pSat == 0.0d0) .and. (TSIn == 0.0d0)) then + if ((pSat == 0.0_wp) .and. (TSIn == 0.0_wp)) then ! assigning Saturation temperature - TSat = 0.0d0 + TSat = 0.0_wp else diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 new file mode 100644 index 0000000000..a95ffbb736 --- /dev/null +++ b/src/common/m_precision_select.f90 @@ -0,0 +1,23 @@ +!> +!! @file m_precision_select.f90 +!! @brief Contains module m_precision_select + +!> @brief This file contains the definition of floating point used in MFC +module m_precision_select +#ifdef MFC_MPI + use mpi !< Message passing interface (MPI) module +#endif + + implicit none + + integer, parameter :: single_precision = selected_real_kind(6, 37) + integer, parameter :: double_precision = selected_real_kind(15, 307) + + integer, parameter :: wp = double_precision +#ifdef MFC_MPI + integer, parameter :: mpi_p = MPI_DOUBLE_PRECISION +#else + integer, parameter :: mpi_p = -100 +#endif + +end module m_precision_select diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 35c1ad9757..ecf7ea8bde 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -68,14 +68,14 @@ module m_variables_conversion ! Importing the derived type scalar_field from m_derived_types.f90 ! and global variable sys_size, from m_global_variables.f90, as ! the abstract interface does not inherently have access to them - import :: scalar_field, sys_size, num_fluids + import :: scalar_field, sys_size, num_fluids, wp type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: i, j, k - real(kind(0d0)), intent(out), target :: rho, gamma, pi_inf, qv - real(kind(0d0)), optional, dimension(2), intent(out) :: Re_K - real(kind(0d0)), optional, intent(out) :: G_K - real(kind(0d0)), optional, dimension(num_fluids), intent(in) :: G + 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 end subroutine s_convert_xxxxx_to_mixture_variables @@ -86,28 +86,28 @@ module m_variables_conversion !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables #ifndef MFC_SIMULATION - real(kind(0d0)), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps + real(wp), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), Gs) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), Gs) @:CRAY_DECLARE_GLOBAL(integer, dimension(:), bubrs) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), Res) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), Res) !$acc declare link(bubrs, Gs, Res) #else - real(kind(0d0)), allocatable, dimension(:) :: Gs + real(wp), allocatable, dimension(:) :: Gs integer, allocatable, dimension(:) :: bubrs - real(kind(0d0)), allocatable, dimension(:, :) :: Res + real(wp), allocatable, dimension(:, :) :: Res !$acc declare create(bubrs, Gs, Res) #endif integer :: is1b, is2b, is3b, is1e, is2e, is3e !$acc declare create(is1b, is2b, is3b, is1e, is2e, is3e) - real(kind(0d0)), allocatable, dimension(:, :, :), public :: rho_sf !< Scalar density function - real(kind(0d0)), allocatable, dimension(:, :, :), public :: gamma_sf !< Scalar sp. heat ratio function - real(kind(0d0)), allocatable, dimension(:, :, :), public :: pi_inf_sf !< Scalar liquid stiffness function - real(kind(0d0)), 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 procedure(s_convert_xxxxx_to_mixture_variables), & pointer :: s_convert_to_mixture_variables => null() !< @@ -130,18 +130,18 @@ contains subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, stress, mom, G) !$acc routine seq - real(kind(0d0)), intent(in) :: energy, alf - real(kind(0d0)), intent(in) :: dyn_p - real(kind(0d0)), intent(in) :: pi_inf, gamma, rho, qv - real(kind(0d0)), intent(out) :: pres - real(kind(0d0)), intent(in), optional :: stress, mom, G + real(wp), intent(in) :: energy, alf + real(wp), intent(in) :: dyn_p + real(wp), intent(in) :: pi_inf, gamma, rho, qv + real(wp), intent(out) :: pres + real(wp), intent(in), optional :: stress, mom, G ! Chemistry integer :: i - real(kind(0d0)), dimension(1:num_species), intent(in) :: rhoYks - real(kind(0d0)) :: E_e - real(kind(0d0)) :: T - real(kind(0d0)), dimension(1:num_species) :: Y_rs + real(wp), dimension(1:num_species), intent(in) :: rhoYks + real(wp) :: E_e + real(wp) :: T + real(wp), dimension(1:num_species) :: Y_rs integer :: s !< Generic loop iterator @@ -152,7 +152,7 @@ contains if ((model_eqns /= 4) .and. (bubbles .neqv. .true.)) then pres = (energy - dyn_p - pi_inf - qv)/gamma else if ((model_eqns /= 4) .and. bubbles) then - pres = ((energy - dyn_p)/(1.d0 - alf) - pi_inf - qv)/gamma + pres = ((energy - dyn_p)/(1._wp - alf) - pi_inf - qv)/gamma else pres = (pref + pi_inf)* & (energy/ & @@ -162,22 +162,22 @@ contains if (hypoelasticity .and. present(G)) then ! calculate elastic contribution to Energy - E_e = 0d0 + E_e = 0._wp do s = stress_idx%beg, stress_idx%end if (G > 0) then - E_e = E_e + ((stress/rho)**2d0)/(4d0*G) + E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) ! Additional terms in 2D and 3D if ((s == stress_idx%beg + 1) .or. & (s == stress_idx%beg + 3) .or. & (s == stress_idx%beg + 4)) then - E_e = E_e + ((stress/rho)**2d0)/(4d0*G) + E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) end if end if end do pres = ( & energy - & - 0.5d0*(mom**2.d0)/rho - & + 0.5_wp*(mom**2._wp)/rho - & pi_inf - qv - E_e & )/gamma @@ -190,10 +190,10 @@ contains end do if (sum(Y_rs) > 1d-16) then - call get_temperature(.true., energy - dyn_p, 1200d0, Y_rs, T) + call get_temperature(.true., energy - dyn_p, 1200._wp, Y_rs, T) call get_pressure(rho, T, Y_rs, pres) else - pres = 0d0 + pres = 0._wp end if #:endif @@ -219,22 +219,22 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: i, j, k - real(kind(0d0)), intent(out), target :: rho - real(kind(0d0)), intent(out), target :: gamma - real(kind(0d0)), intent(out), target :: pi_inf - real(kind(0d0)), 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 - real(kind(0d0)), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, dimension(2), intent(out) :: Re_K - real(kind(0d0)), optional, intent(out) :: G_K - real(kind(0d0)), optional, dimension(num_fluids), intent(in) :: G + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G ! Transferring the density, the specific heat ratio function and the ! liquid stiffness function, respectively rho = q_vf(1)%sf(i, j, k) gamma = q_vf(gamma_idx)%sf(i, j, k) pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) - qv = 0d0 ! keep this value nill for now. For future adjustment + qv = 0._wp ! keep this value nill for now. For future adjustment ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS @@ -267,17 +267,17 @@ contains integer, intent(in) :: j, k, l - real(kind(0d0)), intent(out), target :: rho - real(kind(0d0)), intent(out), target :: gamma - real(kind(0d0)), intent(out), target :: pi_inf - real(kind(0d0)), 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 - real(kind(0d0)), optional, dimension(2), intent(out) :: Re_K - real(kind(0d0)), optional, intent(out) :: G_K - real(kind(0d0)), optional, dimension(num_fluids), intent(in) :: G + real(wp), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G integer :: i, q - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_K, alpha_K + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K ! Constraining the partial densities and the volume fractions within ! their physical bounds to make sure that any mixture variables that @@ -291,8 +291,8 @@ contains if (mpp_lim) then do i = 1, num_fluids - alpha_rho_K(i) = max(0d0, alpha_rho_K(i)) - alpha_K(i) = min(max(0d0, alpha_K(i)), 1d0) + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) end do alpha_K = alpha_K/max(sum(alpha_K), 1d-16) @@ -308,7 +308,7 @@ contains pi_inf = fluid_pp(1)%pi_inf !qK_vf(pi_inf_idx)%sf(i,j,k) qv = fluid_pp(1)%qv else if ((model_eqns == 2) .and. bubbles) then - rho = 0d0; gamma = 0d0; pi_inf = 0d0; qv = 0d0 + rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp if (mpp_lim .and. (num_fluids > 2)) then do i = 1, num_fluids @@ -347,14 +347,14 @@ contains if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 do i = 1, 2 - Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0d0 + Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp do q = 1, Re_size(i) Re_K(i) = (1 - alpha_K(Re_idx(i, q)))/fluid_pp(Re_idx(i, q))%Re(i) & + Re_K(i) end do - Re_K(i) = 1d0/max(Re_K(i), sgm_eps) + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) end do end if @@ -391,17 +391,17 @@ contains integer, intent(in) :: k, l, r - real(kind(0d0)), intent(out), target :: rho - real(kind(0d0)), intent(out), target :: gamma - real(kind(0d0)), intent(out), target :: pi_inf - real(kind(0d0)), 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 - real(kind(0d0)), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, dimension(2), intent(out) :: Re_K !! Partial densities and volume fractions - real(kind(0d0)), optional, intent(out) :: G_K - real(kind(0d0)), optional, dimension(num_fluids), intent(in) :: G + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_K, alpha_K !< + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< integer :: i, j !< Generic loop iterator @@ -416,8 +416,8 @@ contains if (mpp_lim) then do i = 1, num_fluids - alpha_rho_K(i) = max(0d0, alpha_rho_K(i)) - alpha_K(i) = min(max(0d0, alpha_K(i)), 1d0) + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) end do alpha_K = alpha_K/max(sum(alpha_K), 1d-16) @@ -427,7 +427,7 @@ contains ! Calculating the density, the specific heat ratio function, the ! liquid stiffness function, and the energy reference function, ! respectively, from the species analogs - rho = 0d0; gamma = 0d0; pi_inf = 0d0; qv = 0d0 + rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp do i = 1, num_fluids rho = rho + alpha_rho_K(i) @@ -440,24 +440,24 @@ contains ! Computing the shear and bulk Reynolds numbers from species analogs do i = 1, 2 - Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0d0 + Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp do j = 1, Re_size(i) Re_K(i) = alpha_K(Re_idx(i, j))/fluid_pp(Re_idx(i, j))%Re(i) & + Re_K(i) end do - Re_K(i) = 1d0/max(Re_K(i), sgm_eps) + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) end do #endif if (present(G_K)) then - G_K = 0d0 + G_K = 0._wp do i = 1, num_fluids G_K = G_K + alpha_K(i)*G(i) end do - G_K = max(0d0, G_K) + G_K = max(0._wp, G_K) end if ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated @@ -480,36 +480,36 @@ contains !$acc routine seq #endif - real(kind(0d0)), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K + real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K - real(kind(0d0)), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< - real(kind(0d0)), dimension(2), intent(out) :: Re_K + real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(2), intent(out) :: Re_K !! Partial densities and volume fractions - real(kind(0d0)), optional, intent(out) :: G_K - real(kind(0d0)), optional, dimension(num_fluids), intent(in) :: G + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G integer, intent(in) :: k, l, r integer :: i, j !< Generic loop iterators - real(kind(0d0)) :: alpha_K_sum + real(wp) :: alpha_K_sum #ifdef MFC_SIMULATION ! Constraining the partial densities and the volume fractions within ! their physical bounds to make sure that any mixture variables that ! are derived from them result within the limits that are set by the ! fluids physical parameters that make up the mixture - rho_K = 0d0 - gamma_K = 0d0 - pi_inf_K = 0d0 - qv_K = 0d0 + rho_K = 0._wp + gamma_K = 0._wp + pi_inf_K = 0._wp + qv_K = 0._wp - alpha_K_sum = 0d0 + alpha_K_sum = 0._wp if (mpp_lim) then do i = 1, num_fluids - alpha_rho_K(i) = max(0d0, alpha_rho_K(i)) - alpha_K(i) = min(max(0d0, alpha_K(i)), 1d0) + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) alpha_K_sum = alpha_K_sum + alpha_K(i) end do @@ -525,12 +525,12 @@ contains end do if (present(G_K)) then - G_K = 0d0 + G_K = 0._wp do i = 1, num_fluids !TODO: change to use Gs directly here? G_K = G_K + alpha_K(i)*G(i) end do - G_K = max(0d0, G_K) + G_K = max(0._wp, G_K) end if if (any(Re_size > 0)) then @@ -538,14 +538,14 @@ contains do i = 1, 2 Re_K(i) = dflt_real - if (Re_size(i) > 0) Re_K(i) = 0d0 + if (Re_size(i) > 0) Re_K(i) = 0._wp do j = 1, Re_size(i) Re_K(i) = alpha_K(Re_idx(i, j))/Res(i, j) & + Re_K(i) end do - Re_K(i) = 1d0/max(Re_K(i), sgm_eps) + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) end do end if @@ -562,21 +562,21 @@ contains !$acc routine seq #endif - real(kind(0d0)), intent(inout) :: rho_K, gamma_K, pi_inf_K, qv_K + real(wp), intent(inout) :: rho_K, gamma_K, pi_inf_K, qv_K - real(kind(0d0)), dimension(num_fluids), intent(in) :: alpha_K, alpha_rho_K !< + real(wp), dimension(num_fluids), intent(in) :: alpha_K, alpha_rho_K !< !! Partial densities and volume fractions - real(kind(0d0)), dimension(2), intent(out) :: Re_K + real(wp), dimension(2), intent(out) :: Re_K integer, intent(in) :: k, l, r integer :: i, j !< Generic loop iterators #ifdef MFC_SIMULATION - rho_K = 0d0 - gamma_K = 0d0 - pi_inf_K = 0d0 - qv_K = 0d0 + rho_K = 0._wp + gamma_K = 0._wp + pi_inf_K = 0._wp + qv_K = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then do i = 1, num_fluids @@ -605,14 +605,14 @@ contains do i = 1, 2 Re_K(i) = dflt_real - if (Re_size(i) > 0) Re_K(i) = 0d0 + if (Re_size(i) > 0) Re_K(i) = 0._wp do j = 1, Re_size(i) - Re_K(i) = (1d0 - alpha_K(Re_idx(i, j)))/Res(i, j) & + Re_K(i) = (1._wp - alpha_K(Re_idx(i, j)))/Res(i, j) & + Re_K(i) end do - Re_K(i) = 1d0/max(Re_K(i), sgm_eps) + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) end do end if @@ -671,10 +671,10 @@ contains do i = 1, num_fluids gammas(i) = fluid_pp(i)%gamma - gs_min(i) = 1.0d0/gammas(i) + 1.0d0 + gs_min(i) = 1.0_wp/gammas(i) + 1.0_wp pi_infs(i) = fluid_pp(i)%pi_inf Gs(i) = fluid_pp(i)%G - ps_inf(i) = pi_infs(i)/(1.0d0 + gammas(i)) + ps_inf(i) = pi_infs(i)/(1.0_wp + gammas(i)) cvs(i) = fluid_pp(i)%cv qvs(i) = fluid_pp(i)%qv qvps(i) = fluid_pp(i)%qvp @@ -785,10 +785,10 @@ contains !Initialize mv at the quadrature nodes based on the initialized moments and sigma subroutine s_initialize_mv(qK_cons_vf, mv) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(inout) :: mv + real(wp), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(inout) :: mv integer :: i, j, k, l - real(kind(0d0)) :: mu, sig, nbub_sc + real(wp) :: mu, sig, nbub_sc do l = izb, ize do k = iyb, iye @@ -801,10 +801,10 @@ 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 - mv(j, k, l, 1, i) = (mass_v0(i))*(mu - sig)**(3d0)/(R0(i)**(3d0)) - mv(j, k, l, 2, i) = (mass_v0(i))*(mu - sig)**(3d0)/(R0(i)**(3d0)) - mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3d0)/(R0(i)**(3d0)) - mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3d0)/(R0(i)**(3d0)) + mv(j, k, l, 1, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 2, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) end do end do @@ -816,11 +816,11 @@ contains !Initialize pb at the quadrature nodes using isothermal relations (Preston model) subroutine s_initialize_pb(qK_cons_vf, mv, pb) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(in) :: mv - real(kind(0d0)), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(inout) :: pb + real(wp), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(in) :: mv + real(wp), dimension(ixb:, iyb:, izb:, 1:, 1:), intent(inout) :: pb integer :: i, j, k, l - real(kind(0d0)) :: mu, sig, nbub_sc + real(wp) :: mu, sig, nbub_sc do l = izb, ize do k = iyb, iye @@ -834,10 +834,10 @@ contains sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5 !PRESTON (ISOTHERMAL) - pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3d0)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3d0)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3d0)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3d0))*(mass_n0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3d0)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) end do end do end do @@ -866,31 +866,31 @@ contains type(int_bounds_info), optional, intent(in) :: ix, iy, iz - real(kind(0d0)), dimension(num_fluids) :: alpha_K, alpha_rho_K - real(kind(0d0)), dimension(2) :: Re_K - real(kind(0d0)) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K + real(wp), dimension(num_fluids) :: alpha_K, alpha_rho_K + real(wp), dimension(2) :: Re_K + real(wp) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K #:if MFC_CASE_OPTIMIZATION #ifndef MFC_SIMULATION - real(kind(0d0)), dimension(:), allocatable :: nRtmp + real(wp), dimension(:), allocatable :: nRtmp #else - real(kind(0d0)), dimension(nb) :: nRtmp + real(wp), dimension(nb) :: nRtmp #endif #:else - real(kind(0d0)), dimension(:), allocatable :: nRtmp + real(wp), dimension(:), allocatable :: nRtmp #:endif - real(kind(0d0)) :: rhoYks(1:num_species) + real(wp) :: rhoYks(1:num_species) - real(kind(0d0)) :: vftmp, nR3, nbub_sc, R3tmp + real(wp) :: vftmp, nR3, nbub_sc, R3tmp - real(kind(0d0)) :: G_K + real(wp) :: G_K - real(kind(0d0)) :: pres, Yksum + real(wp) :: pres, Yksum integer :: i, j, k, l, q !< Generic loop iterators - real(kind(0.d0)) :: ntmp + real(kind(0._wp)) :: ntmp #:if MFC_CASE_OPTIMIZATION #ifndef MFC_SIMULATION @@ -912,7 +912,7 @@ contains do l = izb, ize do k = iyb, iye do j = ixb, ixe - dyn_pres_K = 0d0 + dyn_pres_K = 0._wp !$acc loop seq do i = 1, num_fluids @@ -946,11 +946,11 @@ contains end if if (chemistry) then - rho_K = 0d0 + rho_K = 0._wp !$acc loop seq do i = chemxb, chemxe !print*, j,k,l, qK_cons_vf(i)%sf(j, k, l) - rho_K = rho_K + max(0d0, qK_cons_vf(i)%sf(j, k, l)) + rho_K = rho_K + max(0._wp, qK_cons_vf(i)%sf(j, k, l)) end do !$acc loop seq @@ -958,10 +958,10 @@ contains qK_prim_vf(i)%sf(j, k, l) = rho_K end do - Yksum = 0d0 + Yksum = 0._wp !$acc loop seq do i = chemxb, chemxe - qK_prim_vf(i)%sf(j, k, l) = max(0d0, qK_cons_vf(i)%sf(j, k, l)/rho_K) + qK_prim_vf(i)%sf(j, k, l) = max(0._wp, qK_cons_vf(i)%sf(j, k, l)/rho_K) Yksum = Yksum + qK_prim_vf(i)%sf(j, k, l) end do @@ -1053,13 +1053,13 @@ contains ! subtracting elastic contribution for pressure calculation if (G_K > 1000) then !TODO: check if stable for >0 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)**2d0)/(4d0*G_K))/gamma_K + ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K ! extra terms in 2 and 3D if ((i == strxb + 1) .or. & (i == strxb + 3) .or. & (i == strxb + 4)) 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)**2d0)/(4d0*G_K))/gamma_K + ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K end if end if end do @@ -1103,21 +1103,21 @@ contains ! Density, specific heat ratio function, liquid stiffness function ! and dynamic pressure, as defined in the incompressible flow sense, ! respectively - real(kind(0d0)) :: rho - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf - real(kind(0d0)) :: qv - real(kind(0d0)) :: dyn_pres - real(kind(0d0)) :: nbub, R3, vftmp, R3tmp - real(kind(0d0)), dimension(nb) :: Rtmp - real(kind(0d0)) :: G = 0d0 - real(kind(0d0)), dimension(2) :: Re_K + real(wp) :: rho + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp) :: dyn_pres + real(wp) :: nbub, R3, vftmp, R3tmp + real(wp), dimension(nb) :: Rtmp + real(wp) :: G = 0._wp + real(wp), dimension(2) :: Re_K integer :: i, j, k, l, q !< Generic loop iterators integer :: spec - real(kind(0d0)), dimension(num_species) :: Ys - real(kind(0d0)) :: temperature, e_mix, mix_mol_weight, T + real(wp), dimension(num_species) :: Ys + real(wp) :: temperature, e_mix, mix_mol_weight, T #ifndef MFC_SIMULATION ! Converting the primitive variables to the conservative variables @@ -1142,13 +1142,13 @@ contains ! Zeroing out the dynamic pressure since it is computed ! iteratively by cycling through the velocity equations - dyn_pres = 0d0 + 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)/2d0 + q_prim_vf(i)%sf(j, k, l)/2._wp end do #:if chemistry @@ -1175,7 +1175,7 @@ contains else if ((model_eqns /= 4) .and. (bubbles)) then ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + & - (1.d0 - q_prim_vf(alf_idx)%sf(j, k, l))* & + (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 @@ -1210,13 +1210,13 @@ contains end if else !Initialize R3 averaging over R0 and R directions - R3tmp = 0d0 + R3tmp = 0._wp do i = 1, nb - R3tmp = R3tmp + weight(i)*0.5d0*(Rtmp(i) + sigR)**3d0 - R3tmp = R3tmp + weight(i)*0.5d0*(Rtmp(i) - sigR)**3d0 + R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) + sigR)**3._wp + R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) - sigR)**3._wp end do !Initialize nb - nbub = 3d0*q_prim_vf(alf_idx)%sf(j, k, l)/(4d0*pi*R3tmp) + nbub = 3._wp*q_prim_vf(alf_idx)%sf(j, k, l)/(4._wp*pi*R3tmp) end if if (j == 0 .and. k == 0 .and. l == 0) print *, 'In convert, nbub:', nbub @@ -1232,13 +1232,13 @@ contains ! adding elastic contribution if (G > 1000) 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)**2d0)/(4d0*G) + (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) ! extra terms in 2 and 3D if ((i == stress_idx%beg + 1) .or. & (i == stress_idx%beg + 3) .or. & (i == stress_idx%beg + 4)) 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)**2d0)/(4d0*G) + (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) end if end if end do @@ -1276,27 +1276,27 @@ contains is1, is2, is3, s2b, s3b) integer, intent(in) :: s2b, s3b - real(kind(0d0)), dimension(0:, s2b:, s3b:, 1:), intent(in) :: qK_prim_vf - real(kind(0d0)), dimension(0:, s2b:, s3b:, 1:), intent(inout) :: FK_vf - real(kind(0d0)), dimension(0:, s2b:, s3b:, advxb:), intent(inout) :: FK_src_vf + real(wp), dimension(0:, s2b:, s3b:, 1:), intent(in) :: qK_prim_vf + real(wp), dimension(0:, s2b:, s3b:, 1:), intent(inout) :: FK_vf + real(wp), dimension(0:, s2b:, s3b:, advxb:), intent(inout) :: FK_src_vf type(int_bounds_info), intent(in) :: is1, is2, is3 ! Partial densities, density, velocity, pressure, energy, advection ! variables, the specific heat ratio and liquid stiffness functions, ! the shear and volume Reynolds numbers and the Weber numbers - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_K - real(kind(0d0)), dimension(num_fluids) :: alpha_K - real(kind(0d0)) :: rho_K - real(kind(0d0)), dimension(num_dims) :: vel_K - real(kind(0d0)) :: vel_K_sum - real(kind(0d0)) :: pres_K - real(kind(0d0)) :: E_K - real(kind(0d0)) :: gamma_K - real(kind(0d0)) :: pi_inf_K - real(kind(0d0)) :: qv_K - real(kind(0d0)), dimension(2) :: Re_K - real(kind(0d0)) :: G_K + real(wp), dimension(num_fluids) :: alpha_rho_K + real(wp), dimension(num_fluids) :: alpha_K + real(wp) :: rho_K + real(wp), dimension(num_dims) :: vel_K + real(wp) :: vel_K_sum + real(wp) :: pres_K + real(wp) :: E_K + real(wp) :: gamma_K + real(wp) :: pi_inf_K + real(wp) :: qv_K + real(wp), dimension(2) :: Re_K + real(wp) :: G_K integer :: i, j, k, l !< Generic loop iterators @@ -1328,10 +1328,10 @@ contains vel_K(i) = qK_prim_vf(j, k, l, contxe + i) end do - vel_K_sum = 0d0 + vel_K_sum = 0._wp !$acc loop seq do i = 1, num_dims - vel_K_sum = vel_K_sum + vel_K(i)**2d0 + vel_K_sum = vel_K_sum + vel_K(i)**2._wp end do pres_K = qK_prim_vf(j, k, l, E_idx) @@ -1371,7 +1371,7 @@ contains if (riemann_solver == 1) then !$acc loop seq do i = advxb, advxe - FK_vf(j, k, l, i) = 0d0 + FK_vf(j, k, l, i) = 0._wp FK_src_vf(j, k, l, i) = alpha_K(i - E_idx) end do @@ -1429,29 +1429,29 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), intent(in) :: pres - real(kind(0d0)), intent(in) :: rho, gamma, pi_inf - real(kind(0d0)), intent(in) :: H - real(kind(0d0)), dimension(num_fluids), intent(in) :: adv - real(kind(0d0)), intent(in) :: vel_sum - real(kind(0d0)), intent(out) :: c + real(wp), intent(in) :: pres + real(wp), intent(in) :: rho, gamma, pi_inf + real(wp), intent(in) :: H + real(wp), dimension(num_fluids), intent(in) :: adv + real(wp), intent(in) :: vel_sum + real(wp), intent(out) :: c - real(kind(0d0)) :: blkmod1, blkmod2 + real(wp) :: blkmod1, blkmod2 integer :: q if (alt_soundspeed) then - blkmod1 = ((gammas(1) + 1d0)*pres + & + blkmod1 = ((gammas(1) + 1._wp)*pres + & pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1d0)*pres + & + blkmod2 = ((gammas(2) + 1._wp)*pres + & pi_infs(2))/gammas(2) - c = (1d0/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) + c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) elseif (model_eqns == 3) then - c = 0d0 + c = 0._wp !$acc loop seq do q = 1, num_fluids - c = c + adv(q)*(1d0/gammas(q) + 1d0)* & - (pres + pi_infs(q)/(gammas(q) + 1d0)) + c = c + adv(q)*(1._wp/gammas(q) + 1._wp)* & + (pres + pi_infs(q)/(gammas(q) + 1._wp)) end do c = c/rho @@ -1459,24 +1459,24 @@ contains ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then - c = (1d0/gamma + 1d0)* & - (pres + pi_inf/(gamma + 1d0))/rho + c = (1._wp/gamma + 1._wp)* & + (pres + pi_inf/(gamma + 1._wp))/rho else c = & - (1d0/gamma + 1d0)* & - (pres + pi_inf/(gamma + 1d0))/ & - (rho*(1d0 - adv(num_fluids))) + (1._wp/gamma + 1._wp)* & + (pres + pi_inf/(gamma + 1._wp))/ & + (rho*(1._wp - adv(num_fluids))) end if else c = ((H - 5d-1*vel_sum)/gamma) end if - if (mixture_err .and. c < 0d0) then - c = 100.d0*sgm_eps + if (mixture_err .and. c < 0._wp) then + c = 100._wp*sgm_eps else c = sqrt(c) end if end subroutine s_compute_speed_of_sound #endif -end module m_variables_conversion +end module m_variables_conversion \ No newline at end of file diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index 3ebdf3f874..e7779987b5 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -104,7 +104,7 @@ contains do i = 1, num_fluids call s_int_to_str(i, iStr) - @:PROHIBIT(.not. f_is_default(schlieren_alpha(i)) .and. schlieren_alpha(i) <= 0d0, & + @:PROHIBIT(.not. f_is_default(schlieren_alpha(i)) .and. schlieren_alpha(i) <= 0._wp, & "schlieren_alpha("//trim(iStr)//") must be greater than zero") @:PROHIBIT(.not. f_is_default(schlieren_alpha(i)) .and. i > num_fluids, & "Index of schlieren_alpha("//trim(iStr)//") exceeds the total number of fluids") diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 567816f73b..4977f3a004 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -74,7 +74,7 @@ subroutine s_read_serial_data_files(t_step) !! Generic string used to store the location of a particular file character(LEN= & - int(floor(log10(real(sys_size, kind(0d0))))) + 1) :: file_num !< + 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 @@ -140,7 +140,7 @@ subroutine s_read_serial_data_files(t_step) 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)/2d0 + x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2._wp ! ================================================================== @@ -167,7 +167,7 @@ subroutine s_read_serial_data_files(t_step) 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)/2d0 + y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp ! ================================================================== @@ -194,7 +194,7 @@ subroutine s_read_serial_data_files(t_step) 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)/2d0 + z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if @@ -254,11 +254,11 @@ subroutine s_read_parallel_data_files(t_step) #ifdef MFC_MPI - real(kind(0d0)), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + 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(kind(0d0)) :: start, finish + real(wp) :: start, finish 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 @@ -283,7 +283,7 @@ subroutine s_read_parallel_data_files(t_step) if (file_exist) then data_size = m_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, x_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -294,7 +294,7 @@ subroutine s_read_parallel_data_files(t_step) ! 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)/2d0 + 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 @@ -304,7 +304,7 @@ subroutine s_read_parallel_data_files(t_step) if (file_exist) then data_size = n_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, y_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -315,7 +315,7 @@ subroutine s_read_parallel_data_files(t_step) ! 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)/2d0 + 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 @@ -325,7 +325,7 @@ subroutine s_read_parallel_data_files(t_step) if (file_exist) then data_size = p_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -336,7 +336,7 @@ subroutine s_read_parallel_data_files(t_step) ! 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)/2d0 + z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if end if @@ -364,8 +364,8 @@ subroutine s_read_parallel_data_files(t_step) 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -375,14 +375,14 @@ subroutine s_read_parallel_data_files(t_step) var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do else do i = 1, adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -438,8 +438,8 @@ subroutine s_read_parallel_data_files(t_step) 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -451,10 +451,10 @@ subroutine s_read_parallel_data_files(t_step) ! 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_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do else do i = 1, sys_size @@ -463,10 +463,10 @@ subroutine s_read_parallel_data_files(t_step) ! 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_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -553,7 +553,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2d0 + x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2._wp end do ! Ghost-cell extrapolation BC at the end @@ -589,7 +589,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2d0 + x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2._wp end do ! END: Populating Buffer Regions in the x-direction ================ @@ -631,7 +631,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2d0 + y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp end do ! Ghost-cell extrapolation BC at the end @@ -667,7 +667,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2d0 + y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2._wp end do ! END: Populating Buffer Regions in the y-direction ================ @@ -709,7 +709,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2d0 + z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2._wp end do ! Ghost-cell extrapolation BC at the end @@ -745,7 +745,7 @@ subroutine s_populate_grid_variables_buffer_regions end do do i = 1, buff_size - z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2d0 + z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp end do end if diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 7aa7e87391..0f131591e8 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -41,9 +41,9 @@ module m_data_output ! database file(s). Note that for 1D simulations, q_root_sf is employed to ! gather the flow variable(s) from all sub-domains on to the root process. ! If the run is not parallel, but serial, then q_root_sf is equal to q_sf. - real(kind(0d0)), allocatable, dimension(:, :, :), public :: q_sf - real(kind(0d0)), allocatable, dimension(:, :, :) :: q_root_sf - real(kind(0d0)), allocatable, dimension(:, :, :) :: cyl_q_sf + real(wp), allocatable, dimension(:, :, :), public :: q_sf + real(wp), allocatable, dimension(:, :, :) :: q_root_sf + real(wp), allocatable, dimension(:, :, :) :: cyl_q_sf ! Single precision storage for flow variables real(kind(0.0)), allocatable, dimension(:, :, :), public :: q_sf_s real(kind(0.0)), allocatable, dimension(:, :, :) :: q_root_sf_s @@ -53,8 +53,8 @@ module m_data_output ! 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(kind(0d0)), allocatable, dimension(:, :) :: spatial_extents - real(kind(0d0)), allocatable, dimension(:, :) :: data_extents + real(wp), allocatable, dimension(:, :) :: spatial_extents + real(wp), allocatable, dimension(:, :) :: data_extents ! The size of the ghost zone layer at beginning of each coordinate direction ! (lo) and at end of each coordinate direction (hi). Adding this information @@ -763,7 +763,7 @@ contains ! Generic loop iterator integer :: i, j, k - real(kind(0d0)) :: start, finish + real(wp) :: start, finish ! Silo-HDF5 Database Format ======================================== diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index e08973bd21..536d4289f5 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -33,7 +33,7 @@ module m_derived_variables s_compute_speed_of_sound, & s_finalize_derived_variables_module - real(kind(0d0)), allocatable, dimension(:, :, :) :: gm_rho_sf !< + 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. @@ -43,9 +43,9 @@ module m_derived_variables !! active coordinate directions, the centered family of the finite-difference !! schemes is used. !> @{ - real(kind(0d0)), allocatable, dimension(:, :), public :: fd_coeff_x - real(kind(0d0)), allocatable, dimension(:, :), public :: fd_coeff_y - real(kind(0d0)), 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 !< @@ -119,7 +119,7 @@ contains !! @param q_sf Specific heat ratio subroutine s_derive_specific_heat_ratio(q_sf) - real(kind(0d0)), & + real(wp), & dimension(-offset_x%beg:m + offset_x%end, & -offset_y%beg:n + offset_y%end, & -offset_z%beg:p + offset_z%end), & @@ -131,7 +131,7 @@ contains do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end - q_sf(i, j, k) = 1d0 + 1d0/gamma_sf(i, j, k) + q_sf(i, j, k) = 1._wp + 1._wp/gamma_sf(i, j, k) end do end do end do @@ -146,7 +146,7 @@ contains !! @param q_sf Liquid stiffness subroutine s_derive_liquid_stiffness(q_sf) - real(kind(0d0)), & + real(wp), & dimension(-offset_x%beg:m + offset_x%end, & -offset_y%beg:n + offset_y%end, & -offset_z%beg:p + offset_z%end), & @@ -159,7 +159,7 @@ contains do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end - q_sf(i, j, k) = pi_inf_sf(i, j, k)/(gamma_sf(i, j, k) + 1d0) + q_sf(i, j, k) = pi_inf_sf(i, j, k)/(gamma_sf(i, j, k) + 1._wp) end do end do end do @@ -179,7 +179,7 @@ contains dimension(sys_size), & intent(in) :: q_prim_vf - real(kind(0d0)), & + real(wp), & dimension(-offset_x%beg:m + offset_x%end, & -offset_y%beg:n + offset_y%end, & -offset_z%beg:p + offset_z%end), & @@ -188,7 +188,7 @@ contains integer :: i, j, k !< Generic loop iterators ! Fluid bulk modulus for alternate sound speed - real(kind(0d0)) :: blkmod1, blkmod2 + real(wp) :: blkmod1, blkmod2 ! Computing speed of sound values from those of pressure, density, ! specific heat ratio function and the liquid stiffness function @@ -198,20 +198,20 @@ contains ! Compute mixture sound speed if (alt_soundspeed .neqv. .true.) then - q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1d0)* & + 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 = ((fluid_pp(1)%gamma + 1d0)*q_prim_vf(E_idx)%sf(i, j, k) + & + blkmod1 = ((fluid_pp(1)%gamma + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + & fluid_pp(1)%pi_inf)/fluid_pp(1)%gamma - blkmod2 = ((fluid_pp(2)%gamma + 1d0)*q_prim_vf(E_idx)%sf(i, j, k) + & + blkmod2 = ((fluid_pp(2)%gamma + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + & fluid_pp(2)%pi_inf)/fluid_pp(2)%gamma - q_sf(i, j, k) = (1d0/(rho_sf(i, j, k)*(q_prim_vf(adv_idx%beg)%sf(i, j, k)/blkmod1 + & - (1d0 - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) + 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) < 0d0) then + if (mixture_err .and. q_sf(i, j, k) < 0._wp) then q_sf(i, j, k) = 1d-16 else q_sf(i, j, k) = sqrt(q_sf(i, j, k)) @@ -236,19 +236,19 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(kind(0d0)), dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end, & + -offset_y%beg:n + offset_y%end, & + -offset_z%beg:p + offset_z%end), & intent(inout) :: q_sf - real(kind(0d0)) :: top, bottom, slope !< Flux limiter calcs + real(wp) :: top, bottom, slope !< Flux limiter calcs integer :: j, k, l !< Generic loop iterators do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end if (i == 1) then - if (q_prim_vf(cont_idx%end + i)%sf(j, k, l) >= 0d0) 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) - & @@ -260,7 +260,7 @@ contains q_prim_vf(adv_idx%beg)%sf(j, k, l) end if elseif (i == 2) then - if (q_prim_vf(cont_idx%end + i)%sf(j, k, l) >= 0d0) 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) - & @@ -272,7 +272,7 @@ contains 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) >= 0d0) 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, l - 1) bottom = q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - & @@ -285,34 +285,34 @@ contains end if end if - if (abs(top) < 1d-8) top = 0d0 - if (abs(bottom) < 1d-8) bottom = 0d0 + if (abs(top) < 1d-8) top = 0._wp + if (abs(bottom) < 1d-8) bottom = 0._wp if (top == bottom) then - slope = 1d0 - ! ELSEIF((top == 0d0 .AND. bottom /= 0d0) & + slope = 1._wp + ! ELSEIF((top == 0._wp .AND. bottom /= 0._wp) & ! .OR. & - ! (bottom == 0d0 .AND. top /= 0d0)) THEN - ! slope = 0d0 + ! (bottom == 0._wp .AND. top /= 0._wp)) THEN + ! slope = 0._wp else - slope = (top*bottom)/(bottom**2d0 + 1d-16) + slope = (top*bottom)/(bottom**2._wp + 1d-16) end if ! Flux limiter function if (flux_lim == 1) then ! MINMOD (MM) - q_sf(j, k, l) = max(0d0, min(1d0, slope)) + q_sf(j, k, l) = max(0._wp, min(1._wp, slope)) elseif (flux_lim == 2) then ! MUSCL (MC) - q_sf(j, k, l) = max(0d0, min(2d0*slope, 5d-1*(1d0 + slope), 2d0)) + q_sf(j, k, l) = max(0._wp, min(2._wp*slope, 5d-1*(1._wp + slope), 2._wp)) elseif (flux_lim == 3) then ! OSPRE (OP) - q_sf(j, k, l) = (15d-1*(slope**2d0 + slope))/(slope**2d0 + slope + 1d0) + q_sf(j, k, l) = (15d-1*(slope**2._wp + slope))/(slope**2._wp + slope + 1._wp) elseif (flux_lim == 4) then ! SUPERBEE (SB) - q_sf(j, k, l) = max(0d0, min(1d0, 2d0*slope), min(slope, 2d0)) + 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) - q_sf(j, k, l) = max(0d0, min(15d-1*slope, 1d0), min(slope, 15d-1)) + q_sf(j, k, l) = max(0._wp, min(15d-1*slope, 1._wp), min(slope, 15d-1)) elseif (flux_lim == 6) then ! VAN ALBADA (VA) - q_sf(j, k, l) = (slope**2d0 + slope)/(slope**2d0 + 1d0) + q_sf(j, k, l) = (slope**2._wp + slope)/(slope**2._wp + 1._wp) elseif (flux_lim == 7) then ! VAN LEER (VL) - q_sf(j, k, l) = (abs(slope) + slope)/(1d0 + abs(slope)) + q_sf(j, k, l) = (abs(slope) + slope)/(1._wp + abs(slope)) end if end do end do @@ -327,9 +327,9 @@ contains subroutine s_solve_linear_system(A, b, sol, ndim) integer, intent(in) :: ndim - real(kind(0d0)), dimension(ndim, ndim), intent(inout) :: A - real(kind(0d0)), dimension(ndim), intent(inout) :: b - real(kind(0d0)), dimension(ndim), intent(out) :: sol + real(wp), dimension(ndim, ndim), intent(inout) :: A + real(wp), dimension(ndim), intent(inout) :: b + real(wp), dimension(ndim), intent(out) :: sol integer, dimension(ndim) :: ipiv @@ -385,7 +385,7 @@ contains dimension(sys_size), & intent(in) :: q_prim_vf - real(kind(0d0)), & + real(wp), & dimension(-offset_x%beg:m + offset_x%end, & -offset_y%beg:n + offset_y%end, & -offset_z%beg:p + offset_z%end), & @@ -399,12 +399,12 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0d0 + 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) + 1d0/y_cc(k)* & + 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)* & @@ -428,7 +428,7 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0d0 + q_sf(j, k, l) = 0._wp do r = -fd_number, fd_number if (grid_geometry == 3) then @@ -456,7 +456,7 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0d0 + q_sf(j, k, l) = 0._wp do r = -fd_number, fd_number q_sf(j, k, l) = & @@ -484,16 +484,16 @@ contains dimension(sys_size), & intent(in) :: q_prim_vf - real(kind(0d0)), & + 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(kind(0d0)), & + real(wp), & dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 - real(kind(0d0)) :: trS, trS2, trO2, Q, IIS + real(wp) :: trS, trS2, trO2, Q, IIS integer :: j, k, l, r, jj, kk !< Generic loop iterators do l = -offset_z%beg, p + offset_z%end @@ -501,7 +501,7 @@ contains do j = -offset_x%beg, m + offset_x%end ! Get velocity gradient tensor - q_jacobian_sf(:, :) = 0d0 + q_jacobian_sf(:, :) = 0._wp do r = -fd_number, fd_number do jj = 1, 3 @@ -526,9 +526,9 @@ contains ! Decompose J into asymmetric matrix, S, and a skew-symmetric matrix, O do jj = 1, 3 do kk = 1, 3 - S(jj, kk) = 0.5d0* & + S(jj, kk) = 0.5_wp* & (q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) - O(jj, kk) = 0.5d0* & + O(jj, kk) = 0.5_wp* & (q_jacobian_sf(jj, kk) - q_jacobian_sf(kk, jj)) end do end do @@ -572,22 +572,22 @@ contains dimension(sys_size), & intent(in) :: q_cons_vf - real(kind(0d0)), & + 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(kind(0d0)) :: drho_dx, drho_dy, drho_dz !< + real(wp) :: drho_dx, drho_dy, drho_dz !< !! Spatial derivatives of the density in the x-, y- and z-directions - real(kind(0d0)), dimension(2) :: gm_rho_max !< + 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(kind(0d0)) :: alpha_unadv !< Unadvected volume fraction + real(wp) :: alpha_unadv !< Unadvected volume fraction integer :: i, j, k, l !< Generic loop iterators @@ -598,8 +598,8 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - drho_dx = 0d0 - drho_dy = 0d0 + drho_dx = 0._wp + drho_dy = 0._wp do i = -fd_number, fd_number drho_dx = drho_dx + fd_coeff_x(i, j)*rho_sf(i + j, k, l) @@ -618,7 +618,7 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - drho_dz = 0d0 + drho_dz = 0._wp do i = -fd_number, fd_number if (grid_geometry == 3) then @@ -648,7 +648,7 @@ contains ! 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, kind(0d0))/) + 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. @@ -674,7 +674,7 @@ contains do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0d0 + q_sf(j, k, l) = 0._wp do i = 1, adv_idx%end - E_idx q_sf(j, k, l) = & diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 312759ab2d..ef2b3f53d9 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -58,18 +58,18 @@ module m_global_parameters !> @name Cell-boundary locations in the x-, y- and z-coordinate directions !> @{ - real(kind(0d0)), allocatable, dimension(:) :: x_cb, x_root_cb, y_cb, z_cb + real(wp), allocatable, dimension(:) :: x_cb, x_root_cb, y_cb, z_cb real(kind(0.0)), allocatable, dimension(:) :: x_cb_s, y_cb_s, z_cb_s !> @} !> @name Cell-center locations in the x-, y- and z-coordinate directions !> @{ - real(kind(0d0)), allocatable, dimension(:) :: x_cc, x_root_cc, y_cc, z_cc + real(wp), allocatable, dimension(:) :: x_cc, x_root_cc, y_cc, z_cc !> @} !> Cell-width distributions in the x-, y- and z-coordinate directions !> @{ - real(kind(0d0)), allocatable, dimension(:) :: dx, dy, dz + real(wp), allocatable, dimension(:) :: dx, dy, dz !> @} integer :: buff_size !< @@ -84,9 +84,9 @@ module m_global_parameters !> @name IO options for adaptive time-stepping !> @{ logical :: cfl_adap_dt, cfl_const_dt, cfl_dt - real(kind(0d0)) :: t_save - real(kind(0d0)) :: t_stop - real(kind(0d0)) :: cfl_target + real(wp) :: t_save + real(wp) :: t_stop + real(wp) :: cfl_target integer :: n_save integer :: n_start !> @} @@ -167,7 +167,7 @@ module m_global_parameters ! ========================================================================== - real(kind(0d0)), allocatable, dimension(:) :: adv !< Advection variables + real(wp), allocatable, dimension(:) :: adv !< Advection variables ! Formatted Database File(s) Structure Parameters ========================== @@ -216,7 +216,7 @@ module m_global_parameters logical :: chem_wrt_T !> @} - real(kind(0d0)), dimension(num_fluids_max) :: schlieren_alpha !< + 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 @@ -236,35 +236,35 @@ module m_global_parameters !> @name Reference parameters for Tait EOS !> @{ - real(kind(0d0)) :: rhoref, pref + real(wp) :: rhoref, pref !> @} !> @name Bubble modeling variables and parameters !> @{ integer :: nb - real(kind(0d0)) :: R0ref - real(kind(0d0)) :: Ca, Web, Re_inv - real(kind(0d0)), dimension(:), allocatable :: weight, R0, V0 + real(wp) :: R0ref + real(wp) :: Ca, Web, Re_inv + real(wp), dimension(:), allocatable :: weight, R0, V0 logical :: bubbles logical :: qbmm logical :: polytropic logical :: polydisperse logical :: adv_n integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer - real(kind(0d0)) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, G, pv, M_n, M_v - real(kind(0d0)), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T - real(kind(0d0)), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - real(kind(0d0)) :: mul0, ss, gamma_v, mu_v - real(kind(0d0)) :: gamma_m, gamma_n, mu_n - real(kind(0d0)) :: poly_sigma - real(kind(0d0)) :: sigR + real(wp) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, G, pv, M_n, M_v + real(wp), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T + real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN + real(wp) :: mul0, ss, gamma_v, mu_v + real(wp) :: gamma_m, gamma_n, mu_n + real(wp) :: poly_sigma + real(wp) :: sigR integer :: nmom !> @} !> @name surface tension coefficient !> @{ - real(kind(0d0)) :: sigma + real(wp) :: sigma !> #} !> @name Index variables used for m_variables_conversion @@ -324,8 +324,8 @@ contains #:for DIM in ['x', 'y', 'z'] #:for DIR in [1, 2, 3] - bc_${DIM}$%vb${DIR}$ = 0d0 - bc_${DIM}$%ve${DIR}$ = 0d0 + bc_${DIM}$%vb${DIR}$ = 0._wp + bc_${DIM}$%ve${DIR}$ = 0._wp #:endfor #:endfor @@ -333,9 +333,9 @@ contains do i = 1, num_fluids_max fluid_pp(i)%gamma = dflt_real fluid_pp(i)%pi_inf = dflt_real - fluid_pp(i)%cv = 0d0 - fluid_pp(i)%qv = 0d0 - fluid_pp(i)%qvp = 0d0 + fluid_pp(i)%cv = 0._wp + fluid_pp(i)%qv = 0._wp + fluid_pp(i)%qvp = 0._wp fluid_pp(i)%G = dflt_real end do @@ -499,12 +499,12 @@ contains end if if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 0d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 0._wp else if (nb > 1) then !call s_simpson - V0(:) = 0d0 + V0(:) = 0._wp else stop 'Invalid value of nb' end if @@ -512,8 +512,8 @@ contains if (polytropic .neqv. .true.) then !call s_initialize_nonpoly else - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if @@ -594,18 +594,18 @@ contains end do if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 0d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 0._wp else if (nb > 1) then - V0(:) = 0d0 + V0(:) = 0._wp else stop 'Invalid value of nb' end if if (polytropic) then - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if end if diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 825f61b490..f121ee1e40 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -29,8 +29,8 @@ module m_mpi_proxy !! processors. Note that these variables are structured as vectors rather !! than arrays. !> @{ - real(kind(0d0)), allocatable, dimension(:) :: q_cons_buffer_in - real(kind(0d0)), allocatable, dimension(:) :: q_cons_buffer_out + real(wp), allocatable, dimension(:) :: q_cons_buffer_in + real(wp), allocatable, dimension(:) :: q_cons_buffer_out !> @} !> @name Receive counts and displacement vector variables, respectively, used in @@ -106,8 +106,8 @@ contains ! Initially zeroing out the vectorized buffer region variables ! to avoid possible underflow from any unused allocated memory - q_cons_buffer_in = 0d0 - q_cons_buffer_out = 0d0 + q_cons_buffer_in = 0._wp + q_cons_buffer_out = 0._wp end if @@ -181,19 +181,19 @@ contains call MPI_BCAST(alpha_wrt(1), num_fluids_max, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) do i = 1, num_fluids_max - call MPI_BCAST(fluid_pp(i)%gamma, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(fluid_pp(i)%pi_inf, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(fluid_pp(i)%cv, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(fluid_pp(i)%qv, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(fluid_pp(i)%qvp, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(fluid_pp(i)%G, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%gamma, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%pi_inf, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%cv, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%qv, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%qvp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%G, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) end do #:for VAR in [ 'pref', 'rhoref', 'R0ref', 'poly_sigma', 'Web', 'Ca', & & 'Re_inv', 'sigma', 't_save', 't_stop' ] - call MPI_BCAST(${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor - call MPI_BCAST(schlieren_alpha(1), num_fluids_max, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(schlieren_alpha(1), num_fluids_max, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_bcast_user_inputs @@ -212,10 +212,10 @@ contains ! Temporary # of processors in x-, y- and z-coordinate directions ! used during the processor factorization optimization procedure - real(kind(0d0)) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z + real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z ! Processor factorization (fct) minimization parameter - real(kind(0d0)) :: fct_min + real(wp) :: fct_min ! Cartesian processor topology communicator integer :: MPI_COMM_CART @@ -261,8 +261,8 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*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 @@ -305,10 +305,10 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + 10d0*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) ! Searching for optimal computational domain distribution do i = 1, num_procs @@ -447,8 +447,8 @@ contains ! Computing minimization variable for these initial values tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y - fct_min = 10d0*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 @@ -666,9 +666,9 @@ contains ! Sending/receiving the data to/from bc_x%end/bc_x%beg call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & dx(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -677,9 +677,9 @@ contains ! Sending/receiving the data to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(dx(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & dx(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -692,9 +692,9 @@ contains ! Sending/receiving the data to/from bc_x%beg/bc_x%end call MPI_SENDRECV(dx(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & dx(m + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -703,9 +703,9 @@ contains ! Sending/receiving the data to/from bc_x%end/bc_x%end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & dx(m + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -726,9 +726,9 @@ contains ! Sending/receiving the data to/from bc_y%end/bc_y%beg call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & + mpi_p, bc_y%end, 0, & dy(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -737,9 +737,9 @@ contains ! Sending/receiving the data to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(dy(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + mpi_p, bc_y%beg, 1, & dy(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -752,9 +752,9 @@ contains ! Sending/receiving the data to/from bc_y%beg/bc_y%end call MPI_SENDRECV(dy(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + mpi_p, bc_y%beg, 1, & dy(n + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -763,9 +763,9 @@ contains ! Sending/receiving the data to/from bc_y%end/bc_y%end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & + mpi_p, bc_y%end, 0, & dy(n + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -786,9 +786,9 @@ contains ! Sending/receiving the data to/from bc_z%end/bc_z%beg call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & dz(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -797,9 +797,9 @@ contains ! Sending/receiving the data to/from bc_z%beg/bc_z%beg call MPI_SENDRECV(dz(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & dz(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -812,9 +812,9 @@ contains ! Sending/receiving the data to/from bc_z%beg/bc_z%end call MPI_SENDRECV(dz(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & dz(p + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -823,9 +823,9 @@ contains ! Sending/receiving the data to/from bc_z%end/bc_z%end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & dz(p + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -889,10 +889,10 @@ contains ! Sending/receiving the data to/from bc_x%end/bc_x%beg call MPI_SENDRECV(q_cons_buffer_out(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & q_cons_buffer_in(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -917,10 +917,10 @@ contains ! Sending/receiving the data to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(q_cons_buffer_out(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & q_cons_buffer_in(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -969,10 +969,10 @@ contains ! Sending/receiving the data to/from bc_x%beg/bc_x%end call MPI_SENDRECV(q_cons_buffer_out(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & q_cons_buffer_in(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -997,10 +997,10 @@ contains ! Sending/receiving the data to/from bc_x%end/bc_x%end call MPI_SENDRECV(q_cons_buffer_out(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & q_cons_buffer_in(0), & buff_size*sys_size*(n + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1059,11 +1059,11 @@ contains ! Sending/receiving the data to/from bc_y%end/bc_y%beg call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & - (p + 1), MPI_DOUBLE_PRECISION, & + (p + 1), mpi_p, & bc_y%end, 0, q_cons_buffer_in(0), & buff_size*sys_size* & (m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1089,11 +1089,11 @@ contains ! Sending/receiving the data to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & - (p + 1), MPI_DOUBLE_PRECISION, & + (p + 1), mpi_p, & bc_y%beg, 1, q_cons_buffer_in(0), & buff_size*sys_size* & (m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1144,11 +1144,11 @@ contains ! Sending/receiving the data to/from bc_y%beg/bc_y%end call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & - (p + 1), MPI_DOUBLE_PRECISION, & + (p + 1), mpi_p, & bc_y%beg, 1, q_cons_buffer_in(0), & buff_size*sys_size* & (m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1175,11 +1175,11 @@ contains ! Sending/receiving the data to/from bc_y%end/bc_y%end call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & - (p + 1), MPI_DOUBLE_PRECISION, & + (p + 1), mpi_p, & bc_y%end, 0, q_cons_buffer_in(0), & buff_size*sys_size* & (m + 2*buff_size + 1)*(p + 1), & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1241,11 +1241,11 @@ contains call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & q_cons_buffer_in(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1273,11 +1273,11 @@ contains call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & q_cons_buffer_in(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1331,11 +1331,11 @@ contains call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & q_cons_buffer_in(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1364,11 +1364,11 @@ contains call MPI_SENDRECV(q_cons_buffer_out(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & q_cons_buffer_in(0), buff_size* & sys_size*(m + 2*buff_size + 1)* & (n + 2*buff_size + 1), & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, & ierr) @@ -1414,7 +1414,7 @@ contains !! the second dimension corresponds to the processor rank. subroutine s_mpi_gather_spatial_extents(spatial_extents) - real(kind(0d0)), dimension(1:, 0:), intent(inout) :: spatial_extents + real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents #ifdef MFC_MPI @@ -1422,102 +1422,102 @@ contains if (p > 0) then if (grid_geometry == 3) then ! Minimum spatial extent in the r-direction - call MPI_GATHERV(minval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(y_cb), 1, mpi_p, & spatial_extents(1, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Minimum spatial extent in the theta-direction - call MPI_GATHERV(minval(z_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(z_cb), 1, mpi_p, & spatial_extents(2, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Minimum spatial extent in the z-direction - call MPI_GATHERV(minval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(x_cb), 1, mpi_p, & spatial_extents(3, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the r-direction - call MPI_GATHERV(maxval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & spatial_extents(4, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the theta-direction - call MPI_GATHERV(maxval(z_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(z_cb), 1, mpi_p, & spatial_extents(5, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the z-direction - call MPI_GATHERV(maxval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & spatial_extents(6, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) else ! Minimum spatial extent in the x-direction - call MPI_GATHERV(minval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(x_cb), 1, mpi_p, & spatial_extents(1, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Minimum spatial extent in the y-direction - call MPI_GATHERV(minval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(y_cb), 1, mpi_p, & spatial_extents(2, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Minimum spatial extent in the z-direction - call MPI_GATHERV(minval(z_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(z_cb), 1, mpi_p, & spatial_extents(3, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the x-direction - call MPI_GATHERV(maxval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & spatial_extents(4, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the y-direction - call MPI_GATHERV(maxval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & spatial_extents(5, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the z-direction - call MPI_GATHERV(maxval(z_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(z_cb), 1, mpi_p, & spatial_extents(6, 0), recvcounts, 6*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) end if ! Simulation is 2D else ! Minimum spatial extent in the x-direction - call MPI_GATHERV(minval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(x_cb), 1, mpi_p, & spatial_extents(1, 0), recvcounts, 4*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Minimum spatial extent in the y-direction - call MPI_GATHERV(minval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(y_cb), 1, mpi_p, & spatial_extents(2, 0), recvcounts, 4*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the x-direction - call MPI_GATHERV(maxval(x_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & spatial_extents(3, 0), recvcounts, 4*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Maximum spatial extent in the y-direction - call MPI_GATHERV(maxval(y_cb), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & spatial_extents(4, 0), recvcounts, 4*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) end if @@ -1538,17 +1538,17 @@ contains ! Silo-HDF5 database format if (format == 1) then - call MPI_GATHERV(x_cc(0), m + 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(x_cc(0), m + 1, mpi_p, & x_root_cc(0), recvcounts, displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) ! Binary database format else - call MPI_GATHERV(x_cb(0), m + 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(x_cb(0), m + 1, mpi_p, & x_root_cb(0), recvcounts, displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, & + mpi_p, 0, MPI_COMM_WORLD, & ierr) if (proc_rank == 0) x_root_cb(-1) = x_cb(-1) @@ -1569,23 +1569,23 @@ contains !! to each processor's rank. subroutine s_mpi_gather_data_extents(q_sf, data_extents) - real(kind(0d0)), dimension(:, :, :), intent(in) :: q_sf + real(wp), dimension(:, :, :), intent(in) :: q_sf - real(kind(0d0)), & + real(wp), & dimension(1:2, 0:num_procs - 1), & intent(inout) :: data_extents #ifdef MFC_MPI ! Minimum flow variable extent - call MPI_GATHERV(minval(q_sf), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(minval(q_sf), 1, mpi_p, & data_extents(1, 0), recvcounts, 2*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + mpi_p, 0, MPI_COMM_WORLD, ierr) ! Maximum flow variable extent - call MPI_GATHERV(maxval(q_sf), 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(maxval(q_sf), 1, mpi_p, & data_extents(2, 0), recvcounts, 2*displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + mpi_p, 0, MPI_COMM_WORLD, ierr) #endif @@ -1599,11 +1599,11 @@ contains !! @param q_root_sf Flow variable defined on the entire computational domain subroutine s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) - real(kind(0d0)), & + real(wp), & dimension(0:m, 0:0, 0:0), & intent(in) :: q_sf - real(kind(0d0)), & + real(wp), & dimension(0:m_root, 0:0, 0:0), & intent(inout) :: q_root_sf @@ -1612,9 +1612,9 @@ contains ! Gathering the sub-domain flow variable data from all the processes ! and putting it back together for the entire computational domain ! on the process with rank 0 - call MPI_GATHERV(q_sf(0, 0, 0), m + 1, MPI_DOUBLE_PRECISION, & + call MPI_GATHERV(q_sf(0, 0, 0), m + 1, mpi_p, & q_root_sf(0, 0, 0), recvcounts, displs, & - MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + mpi_p, 0, MPI_COMM_WORLD, ierr) #endif diff --git a/src/post_process/m_start_up.f90 b/src/post_process/m_start_up.f90 index 78b42a7bff..077b638d8a 100644 --- a/src/post_process/m_start_up.f90 +++ b/src/post_process/m_start_up.f90 @@ -156,11 +156,11 @@ subroutine s_perform_time_step(t_step) if (proc_rank == 0) then if (cfl_dt) then print '(" ["I3"%] Saving "I8" of "I0"")', & - int(ceiling(100d0*(real(t_step - n_start)/(n_save)))), & + int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), & t_step, n_save else print '(" ["I3"%] Saving "I8" of "I0" @ t_step = "I0"")', & - int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + 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 @@ -188,7 +188,7 @@ subroutine s_save_data(t_step, varname, pres, c, H) integer, intent(inout) :: t_step character(LEN=name_len), intent(inout) :: varname - real(kind(0d0)), intent(inout) :: pres, c, H + real(wp), intent(inout) :: pres, c, H integer :: i, j, k, l @@ -482,12 +482,12 @@ subroutine s_save_data(t_step, varname, pres, c, H) pres = q_prim_vf(E_idx)%sf(i, j, k) - H = ((gamma_sf(i, j, k) + 1d0)*pres + & + H = ((gamma_sf(i, j, k) + 1._wp)*pres + & pi_inf_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, 0d0, c) + H, adv, 0._wp, c) q_sf(i, j, k) = c end do diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index e48bb80114..15ebe93c7c 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -26,9 +26,9 @@ program p_main !! Generic storage for the name(s) of the flow variable(s) that will be added !! to the formatted database file(s) - real(kind(0d0)) :: pres - real(kind(0d0)) :: c - real(kind(0d0)) :: H + real(wp) :: pres + real(wp) :: c + real(wp) :: H call s_initialize_mpi_domain() diff --git a/src/pre_process/include/2dHardcodedIC.fpp b/src/pre_process/include/2dHardcodedIC.fpp index 7d6ee9602b..23f11a465e 100644 --- a/src/pre_process/include/2dHardcodedIC.fpp +++ b/src/pre_process/include/2dHardcodedIC.fpp @@ -1,9 +1,9 @@ #:def Hardcoded2DVariables() - real(kind(0d0)) :: eps - real(kind(0d0)) :: r, rmax, gam, umax, p0 + real(wp) :: eps + real(wp) :: r, rmax, gam, umax, p0 - real(kind(0d0)) :: rhoH, rhoL, pRef, pInt, h, lam, wl, amp, intH, alph + real(wp) :: rhoH, rhoL, pRef, pInt, h, lam, wl, amp, intH, alph eps = 1e-9 @@ -13,60 +13,60 @@ select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case case (200) - if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1d0/3d0)) then + 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) = 1d0 - eps + q_prim_vf(advxe)%sf(i, j, 0) = 1._wp - eps ! Denssities - q_prim_vf(contxb)%sf(i, j, 0) = eps*1000d0 - q_prim_vf(contxe)%sf(i, j, 0) = (1d0 - eps)*1d0 + 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) = 1000d0 + q_prim_vf(E_idx)%sf(i, j, 0) = 1000._wp end if case (202) ! Gresho vortex (Gouasmi et al 2022 JCP) - r = ((x_cc(i) - 0.5d0)**2 + (y_cc(j) - 0.5d0)**2)**0.5d0 + r = ((x_cc(i) - 0.5_wp)**2 + (y_cc(j) - 0.5_wp)**2)**0.5_wp rmax = 0.2 - gam = 1d0 + 1d0/fluid_pp(1)%gamma + gam = 1._wp + 1._wp/fluid_pp(1)%gamma umax = 2*pi*rmax*patch_icpp(patch_id)%vel(2) - p0 = umax**2*(1d0/(gam*patch_icpp(patch_id)%vel(2)**2) - 0.5d0) + p0 = umax**2*(1._wp/(gam*patch_icpp(patch_id)%vel(2)**2) - 0.5_wp) if (r < rmax) then - q_prim_vf(momxb)%sf(i, j, 0) = -(y_cc(j) - 0.5d0)*umax/rmax - q_prim_vf(momxe)%sf(i, j, 0) = (x_cc(i) - 0.5d0)*umax/rmax - q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2d0) + q_prim_vf(momxb)%sf(i, j, 0) = -(y_cc(j) - 0.5_wp)*umax/rmax + q_prim_vf(momxe)%sf(i, j, 0) = (x_cc(i) - 0.5_wp)*umax/rmax + q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2._wp) else if (r < 2*rmax) then - q_prim_vf(momxb)%sf(i, j, 0) = -((y_cc(j) - 0.5d0)/r)*umax*(2d0 - r/rmax) - q_prim_vf(momxe)%sf(i, j, 0) = ((x_cc(i) - 0.5d0)/r)*umax*(2d0 - r/rmax) - q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2d0 + 4*(1 - (r/rmax) + log(r/rmax))) + q_prim_vf(momxb)%sf(i, j, 0) = -((y_cc(j) - 0.5_wp)/r)*umax*(2._wp - r/rmax) + q_prim_vf(momxe)%sf(i, j, 0) = ((x_cc(i) - 0.5_wp)/r)*umax*(2._wp - r/rmax) + q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2._wp + 4*(1 - (r/rmax) + log(r/rmax))) else - q_prim_vf(momxb)%sf(i, j, 0) = 0d0 - q_prim_vf(momxe)%sf(i, j, 0) = 0d0 + q_prim_vf(momxb)%sf(i, j, 0) = 0._wp + 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.)) end if case (203) ! Gresho vortex (Gouasmi et al 2022 JCP) with density correction - r = ((x_cc(i) - 0.5d0)**2 + (y_cc(j) - 0.5d0)**2)**0.5d0 + r = ((x_cc(i) - 0.5_wp)**2 + (y_cc(j) - 0.5_wp)**2)**0.5_wp rmax = 0.2 - gam = 1d0 + 1d0/fluid_pp(1)%gamma + gam = 1._wp + 1._wp/fluid_pp(1)%gamma umax = 2*pi*rmax*patch_icpp(patch_id)%vel(2) - p0 = umax**2*(1d0/(gam*patch_icpp(patch_id)%vel(2)**2) - 0.5d0) + p0 = umax**2*(1._wp/(gam*patch_icpp(patch_id)%vel(2)**2) - 0.5_wp) if (r < rmax) then - q_prim_vf(momxb)%sf(i, j, 0) = -(y_cc(j) - 0.5d0)*umax/rmax - q_prim_vf(momxe)%sf(i, j, 0) = (x_cc(i) - 0.5d0)*umax/rmax - q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2d0) + q_prim_vf(momxb)%sf(i, j, 0) = -(y_cc(j) - 0.5_wp)*umax/rmax + q_prim_vf(momxe)%sf(i, j, 0) = (x_cc(i) - 0.5_wp)*umax/rmax + q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2._wp) else if (r < 2*rmax) then - q_prim_vf(momxb)%sf(i, j, 0) = -((y_cc(j) - 0.5d0)/r)*umax*(2d0 - r/rmax) - q_prim_vf(momxe)%sf(i, j, 0) = ((x_cc(i) - 0.5d0)/r)*umax*(2d0 - r/rmax) - q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2d0 + 4*(1 - (r/rmax) + log(r/rmax))) + q_prim_vf(momxb)%sf(i, j, 0) = -((y_cc(j) - 0.5_wp)/r)*umax*(2._wp - r/rmax) + q_prim_vf(momxe)%sf(i, j, 0) = ((x_cc(i) - 0.5_wp)/r)*umax*(2._wp - r/rmax) + q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*((r/rmax)**2/2._wp + 4*(1 - (r/rmax) + log(r/rmax))) else - q_prim_vf(momxb)%sf(i, j, 0) = 0d0 - q_prim_vf(momxe)%sf(i, j, 0) = 0d0 + q_prim_vf(momxb)%sf(i, j, 0) = 0._wp + 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.)) end if - q_prim_vf(contxb)%sf(i, j, 0) = q_prim_vf(E_idx)%sf(i, j, 0)**(1d0/gam) + 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 rhoH = 3 diff --git a/src/pre_process/include/3dHardcodedIC.fpp b/src/pre_process/include/3dHardcodedIC.fpp index 3d9a4e2f1d..4448297ec5 100644 --- a/src/pre_process/include/3dHardcodedIC.fpp +++ b/src/pre_process/include/3dHardcodedIC.fpp @@ -1,9 +1,9 @@ #:def Hardcoded3DVariables() ! Place any declaration of intermediate variables here - real(kind(0d0)) :: rhoH, rhoL, pRef, pInt, h, lam, wl, amp, intH, alph + real(wp) :: rhoH, rhoL, pRef, pInt, h, lam, wl, amp, intH, alph - real(kind(0d0)) :: eps + real(wp) :: eps eps = 1e-9 #:enddef diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index d5d3e9bcd2..443e6d7b10 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -89,7 +89,7 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 & - .or. patch_ib(patch_id)%radius <= 0d0 & + .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)) @@ -107,10 +107,10 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 & - .or. patch_ib(patch_id)%c <= 0d0 & - .or. patch_ib(patch_id)%p <= 0d0 & - .or. patch_ib(patch_id)%t <= 0d0 & - .or. patch_ib(patch_id)%m <= 0d0 & + .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)) @@ -128,10 +128,10 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p == 0 & - .or. patch_ib(patch_id)%c <= 0d0 & - .or. patch_ib(patch_id)%p <= 0d0 & - .or. patch_ib(patch_id)%t <= 0d0 & - .or. patch_ib(patch_id)%m <= 0d0 & + .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) & @@ -156,9 +156,9 @@ contains .or. & f_is_default(patch_ib(patch_id)%y_centroid) & .or. & - patch_ib(patch_id)%length_x <= 0d0 & + patch_ib(patch_id)%length_x <= 0._wp & .or. & - patch_ib(patch_id)%length_y <= 0d0, & + patch_ib(patch_id)%length_y <= 0._wp, & 'in rectangle IB patch '//trim(iStr)) end subroutine s_check_rectangle_ib_patch_geometry @@ -181,7 +181,7 @@ contains .or. & f_is_default(patch_ib(patch_id)%z_centroid) & .or. & - patch_ib(patch_id)%radius <= 0d0, & + patch_ib(patch_id)%radius <= 0._wp, & 'in sphere IB patch '//trim(iStr)) end subroutine s_check_sphere_ib_patch_geometry @@ -204,23 +204,23 @@ contains .or. & f_is_default(patch_ib(patch_id)%z_centroid) & .or. & - (patch_ib(patch_id)%length_x <= 0d0 .and. & - patch_ib(patch_id)%length_y <= 0d0 .and. & - patch_ib(patch_id)%length_z <= 0d0) & + (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 <= 0d0, & + patch_ib(patch_id)%radius <= 0._wp, & 'in cylinder IB patch '//trim(iStr)) @:PROHIBIT( & - (patch_ib(patch_id)%length_x > 0d0 .and. & + (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 > 0d0 .and. & + (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 > 0d0 .and. & + (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)) diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index a9ddc3883b..64864bbb31 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -155,7 +155,7 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(n > 0, "Line segment patch "//trim(iStr)//": n must be zero") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "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") @@ -170,7 +170,7 @@ contains @:PROHIBIT(n == 0, "Circle patch "//trim(iStr)//": n must be zero") @:PROHIBIT(p > 0, "Circle patch "//trim(iStr)//": p must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radius <= 0d0, "Circle patch "//trim(iStr)//": radius must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Circle patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Circle patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Circle patch "//trim(iStr)//": y_centroid must be set") @@ -187,8 +187,8 @@ contains @:PROHIBIT(p > 0, "Rectangle patch "//trim(iStr)//": p must be zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Rectangle patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Rectangle patch "//trim(iStr)//": y_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "Rectangle patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0d0, "Rectangle patch "//trim(iStr)//": length_y must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Rectangle patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Rectangle patch "//trim(iStr)//": length_y must be greater than zero") end subroutine s_check_rectangle_patch_geometry @@ -220,8 +220,8 @@ contains @:PROHIBIT(p > 0, "Ellipse patch "//trim(iStr)//": p must be zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Ellipse patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Ellipse patch "//trim(iStr)//": y_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0d0, "Ellipse patch "//trim(iStr)//": radii(1) must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0d0, "Ellipse patch "//trim(iStr)//": radii(2) must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(1) must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Ellipse patch "//trim(iStr)//": radii(3) must not be set") end subroutine s_check_ellipse_patch_geometry @@ -237,9 +237,9 @@ contains @: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 <= 0d0, "Taylor Green vortex patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0d0, "Taylor Green vortex patch "//trim(iStr)//": length_y must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0d0, "Taylor Green vortex patch "//trim(iStr)//": vel(2) must be greater than zero") + @: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 @@ -254,7 +254,7 @@ contains @:PROHIBIT(p > 0, "1D analytical patch "//trim(iStr)//": p must be zero") @:PROHIBIT(model_eqns /= 4 .and. model_eqns /= 2, "1D analytical patch "//trim(iStr)//": model_eqns must be either 4 or 2") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "1D analytical patch "//trim(iStr)//": x_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "1D analytical patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "1D analytical patch "//trim(iStr)//": length_x must be greater than zero") end subroutine s_check_1D_analytical_patch_geometry @@ -269,8 +269,8 @@ contains @:PROHIBIT(p > 0, "2D analytical patch "//trim(iStr)//": p must be zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "2D analytical patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "2D analytical patch "//trim(iStr)//": y_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "2D analytical patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0d0, "2D analytical patch "//trim(iStr)//": length_y must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "2D analytical patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "2D analytical patch "//trim(iStr)//": length_y must be greater than zero") end subroutine s_check_2D_analytical_patch_geometry @@ -285,9 +285,9 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "3D analytical patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "3D analytical patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "3D analytical patch "//trim(iStr)//": z_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "3D analytical patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0d0, "3D analytical patch "//trim(iStr)//": length_y must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0d0, "3D analytical patch "//trim(iStr)//": length_z must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "3D analytical patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "3D analytical patch "//trim(iStr)//": length_y must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0._wp, "3D analytical patch "//trim(iStr)//": length_z must be greater than zero") end subroutine s_check_3D_analytical_patch_geometry @@ -299,7 +299,7 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Sphere patch "//trim(iStr)//": p must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radius <= 0d0, "Sphere patch "//trim(iStr)//": radius must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Sphere patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Sphere patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Sphere patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Sphere patch "//trim(iStr)//": z_centroid must be set") @@ -314,13 +314,13 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Spherical harmonic patch "//trim(iStr)//": p must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radius <= 0d0, "Spherical harmonic patch "//trim(iStr)//": radius 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(all(patch_icpp(patch_id)%epsilon /= (/1d0, 2d0, 3d0, 4d0, 5d0/)), & + @:PROHIBIT(all(patch_icpp(patch_id)%epsilon /= (/1._wp, 2._wp, 3._wp, 4._wp, 5._wp/)), & "Spherical harmonic patch "//trim(iStr)//": epsilon must be one of 1, 2, 3, 4, 5") - @:PROHIBIT(patch_icpp(patch_id)%beta < 0d0, & + @:PROHIBIT(patch_icpp(patch_id)%beta < 0._wp, & "Spherical harmonic patch "//trim(iStr)//": beta must be greater than or equal to zero") @:PROHIBIT(patch_icpp(patch_id)%beta > patch_icpp(patch_id)%epsilon, & "Spherical harmonic patch "//trim(iStr)//": beta must be less than or equal to epsilon") @@ -339,9 +339,9 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Cuboid patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Cuboid patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Cuboid patch "//trim(iStr)//": z_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0d0, "Cuboid patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0d0, "Cuboid patch "//trim(iStr)//": length_y must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0d0, "Cuboid patch "//trim(iStr)//": length_z must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Cuboid patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Cuboid patch "//trim(iStr)//": length_y must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0._wp, "Cuboid patch "//trim(iStr)//": length_z must be greater than zero") end subroutine s_check_cuboid_patch_geometry @@ -357,20 +357,20 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Cylinder patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Cylinder patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Cylinder patch "//trim(iStr)//": z_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%radius <= 0d0, "Cylinder patch "//trim(iStr)//": radius must be greater than zero") + @: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 > 0d0, & - patch_icpp(patch_id)%length_y > 0d0, & - patch_icpp(patch_id)%length_z > 0d0 & + 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 <= 0d0) .or. & - (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0d0) .or. & - (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0d0), & + (.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 @@ -404,9 +404,9 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Ellipsoid patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Ellipsoid patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Ellipsoid patch "//trim(iStr)//": z_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0d0, "Ellipsoid patch "//trim(iStr)//": radii(1) must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0d0, "Ellipsoid patch "//trim(iStr)//": radii(2) must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radii(3) <= 0d0, "Ellipsoid patch "//trim(iStr)//": radii(3) must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(1) must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(2) must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%radii(3) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(3) must be greater than zero") end subroutine s_check_ellipsoid_patch_geometry @@ -474,7 +474,7 @@ contains "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be less than patch_id") @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, & "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0d0, & + @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, & "Smoothen enabled. Patch "//trim(iStr)//": smooth_coeff must be greater than zero") else @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & @@ -520,15 +520,15 @@ contains "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(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0d0, & + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, & "Patch "//trim(iStr)//": rho must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0d0, & + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, & "Patch "//trim(iStr)//": gamma must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0d0, & + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, & "Patch "//trim(iStr)//": pi_inf must be greater than or equal to zero when model_eqns = 1") @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, & "Patch "//trim(iStr)//": pi_inf must be less than or equal to zero when geometry = 5") - @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0d0), & + @: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") if (model_eqns == 2 .and. num_fluids < num_fluids_max) then diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index efd1ef1904..ec5600c76c 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -87,11 +87,11 @@ contains "n must be positive (2D or 3D) for cylindrical coordinates") @:PROHIBIT(cyl_coord .and. (f_is_default(y_domain%beg) .or. f_is_default(y_domain%end)), & "y_domain%beg and y_domain%end must be set for n = 0 (2D cylindrical coordinates)") - @:PROHIBIT(cyl_coord .and. (y_domain%beg /= 0d0 .or. y_domain%end <= 0d0), & + @:PROHIBIT(cyl_coord .and. (y_domain%beg /= 0._wp .or. y_domain%end <= 0._wp), & "y_domain%beg must be 0 and y_domain%end must be positive for cylindrical coordinates") @:PROHIBIT(cyl_coord .and. p == 0 .and. ((.not. f_is_default(z_domain%beg)) .or. (.not. f_is_default(z_domain%end))), & "z_domain%beg and z_domain%end are not supported for p = 0 (2D cylindrical coordinates)") - @:PROHIBIT(cyl_coord .and. p > 0 .and. (z_domain%beg /= 0d0 .or. z_domain%end /= 2d0*pi), & + @:PROHIBIT(cyl_coord .and. p > 0 .and. (z_domain%beg /= 0._wp .or. z_domain%end /= 2._wp*pi), & "z_domain%beg must be 0 and z_domain%end must be 2*pi for 3D cylindrical coordinates") @:PROHIBIT(num_patches < 0) @@ -124,11 +124,11 @@ contains !&< Deactivate prettify @:PROHIBIT(stretch_${X}$ .and. (a_${X}$ + log(cosh(a_${X}$*(${X}$_domain%beg - ${X}$_a))) & + log(cosh(a_${X}$*(${X}$_domain%beg - ${X}$_b))) & - - 2d0*log(cosh(0.5d0*a_${X}$*(${X}$_b - ${X}$_a)))) / a_${X}$ <= 0d0, & + - 2._wp*log(cosh(0.5_wp*a_${X}$*(${X}$_b - ${X}$_a)))) / a_${X}$ <= 0._wp, & "${X}$_domain%beg is too close to ${X}$_a and ${X}$_b for the given a_${X}$") @:PROHIBIT(stretch_${X}$ .and. (a_${X}$ + log(cosh(a_${X}$*(${X}$_domain%end - ${X}$_a))) & + log(cosh(a_${X}$*(${X}$_domain%end - ${X}$_b))) & - - 2d0*log(cosh(0.5d0*a_${X}$*(${X}$_b - ${X}$_a)))) / a_${X}$ <= 0d0, & + - 2._wp*log(cosh(0.5_wp*a_${X}$*(${X}$_b - ${X}$_a)))) / a_${X}$ <= 0._wp, & "${X}$_domain%end is too close to ${X}$_a and ${X}$_b for the given a_${X}$") !&> #:endfor @@ -138,7 +138,7 @@ contains !! (qbmm, polydisperse, dist_type, rhoRV, and R0_type) subroutine s_check_inputs_qbmm_and_polydisperse @:PROHIBIT(qbmm .and. dist_type == dflt_int, "dist_type must be set if using QBMM") - @:PROHIBIT(qbmm .and. dist_type /= 1 .and. rhoRV > 0d0, "rhoRV cannot be used with dist_type != 1") + @:PROHIBIT(qbmm .and. dist_type /= 1 .and. rhoRV > 0._wp, "rhoRV cannot be used with dist_type != 1") @:PROHIBIT(polydisperse .and. R0_type == dflt_int, "R0 type must be set if using Polydisperse") end subroutine s_check_inputs_qbmm_and_polydisperse diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index e17773787f..66c646ba4d 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -2,850 +2,994 @@ !! @file m_data_output.f90 !! @brief Contains module m_data_output -!> @brief This module takes care of writing the grid and initial condition -!! data files into the "0" time-step directory located in the folder -!! associated with the rank of the local processor, which is a sub- -!! directory of the case folder specified by the user in the input -!! file pre_process.inp. +!> @brief This module enables the restructuring of the raw simulation data +!! file(s) into formatted database file(s). The formats that may be +!! chosen from include Silo-HDF5 and Binary. Each of these database +!! structures contains information about the grid as well as each of +!! the flow variable(s) that were chosen by the user to be included. module m_data_output ! Dependencies ============================================================= - use m_derived_types !< Definitions of the derived types + ! USE f90_unix_proc ! NAG Compiler Library of UNIX system commands - use m_global_parameters !< Global parameters for the code + use m_derived_types ! Definitions of the derived types - use m_helper - - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_global_parameters ! Global parameters for the code -#ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module -#endif + use m_mpi_proxy ! Message passing interface (MPI) module proxy use m_compile_specific - use m_variables_conversion - use m_helper - - use m_delay_file_access ! ========================================================================== 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_initialize_data_output_module, & + s_open_formatted_database_file, & + s_write_grid_to_formatted_database_file, & + s_write_variable_to_formatted_database_file, & + s_close_formatted_database_file, & + s_finalize_data_output_module + + ! Including the Silo Fortran interface library that features the subroutines + ! and parameters that are required to write in the Silo-HDF5 database format + ! INCLUDE 'silo.inc' + include 'silo_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 + ! Single precision storage for flow variables + real(kind(0.0)), allocatable, dimension(:, :, :), public :: q_sf_s + real(kind(0.0)), allocatable, dimension(:, :, :) :: q_root_sf_s + real(kind(0.0)), 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. + 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. + integer, allocatable, dimension(:) :: dims + + ! Locations of various folders in the case's directory tree, associated with + ! the choice of the formatted database format. These include, in order, the + ! location of the folder named after the selected formatted database format, + ! and the locations of two sub-directories of the latter, the first of which + ! is named after the local processor rank, while the second is named 'root'. + ! The folder associated with the local processor rank contains only the data + ! pertaining to the part of the domain taken care of by the local processor. + ! The root directory, on the other hand, will contain either the information + ! about the connectivity required to put the entire domain back together, or + ! the actual data associated with the entire computational domain. This all + ! depends on dimensionality and the choice of the formatted database format. + character(LEN=path_len + name_len) :: dbdir + character(LEN=path_len + 2*name_len) :: proc_rank_dir + character(LEN=path_len + 2*name_len) :: rootdir + + ! Handles of the formatted database master/root file, slave/local processor + ! file and options list. The list of options is explicitly used in the Silo- + ! HDF5 database format to provide additional details about the contents of a + ! formatted database file, such as the previously described spatial and data + ! extents. + integer :: dbroot + integer :: dbfile + integer :: optlist + + ! The total number of flow variable(s) to be stored in a formatted database + ! file. Note that this is only needed when using the Binary format. + integer :: dbvars + + ! Generic error flags utilized in the handling, checking and the reporting + ! of the input and output operations errors with a formatted database file + integer, private :: err, ierr - abstract interface ! =================================================== +contains - !> Interface for the conservative data - !! @param q_cons_vf Conservative variables - !! @param ib_markers track if a cell is within the immersed boundary - subroutine s_write_abstract_data_files(q_cons_vf, ib_markers) + subroutine s_initialize_data_output_module + ! Description: Computation of parameters, allocation procedures, and/or + ! any other tasks needed to properly setup the module - import :: scalar_field, integer_field, sys_size, m, n, p, pres_field + ! Generic string used to store the location of a particular file + character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc - ! Conservative variables - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_cons_vf + ! Generic logical used to test the existence of a particular folder + logical :: dir_check - ! IB markers - type(integer_field), & - intent(in) :: ib_markers + ! Generic loop iterator + integer :: i - end subroutine s_write_abstract_data_files - end interface ! ======================================================== + ! Allocating the generic storage for the flow variable(s) that are + ! going to be written to the formatted database file(s). Note once + ! more that the root variable is only required for 1D computations. + allocate (q_sf(-offset_x%beg:m + offset_x%end, & + -offset_y%beg:n + offset_y%end, & + -offset_z%beg:p + offset_z%end)) + if (grid_geometry == 3) then + allocate (cyl_q_sf(-offset_y%beg:n + offset_y%end, & + -offset_z%beg:p + offset_z%end, & + -offset_x%beg:m + offset_x%end)) + end if - character(LEN=path_len + 2*name_len), private :: t_step_dir !< - !! Time-step folder into which grid and initial condition data will be placed + 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)) + 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)) + end if + end if - character(LEN=path_len + 2*name_len), public :: restart_dir !< - !! Restart data folder + if (n == 0) then + 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)) + end if + end if - procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() + ! 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 .and. n > 0) then -contains + allocate (data_extents(1:2, 0:num_procs - 1)) - !> 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 ib_markers track if a cell is within the immersed boundary - subroutine s_write_serial_data_files(q_cons_vf, ib_markers) - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_cons_vf + if (p > 0) then + allocate (spatial_extents(1:6, 0:num_procs - 1)) + allocate (lo_offset(1:3)) + allocate (hi_offset(1:3)) + allocate (dims(1:3)) + else + allocate (spatial_extents(1:4, 0:num_procs - 1)) + allocate (lo_offset(1:2)) + allocate (hi_offset(1:2)) + allocate (dims(1:2)) + end if - ! IB markers - type(integer_field), & - intent(in) :: ib_markers + end if - logical :: file_exist !< checks if file exists + ! 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 .and. n > 0) then + if (p > 0) then + if (grid_geometry == 3) then + lo_offset = (/offset_y%beg, offset_z%beg, offset_x%beg/) + hi_offset = (/offset_y%end, offset_z%end, offset_x%end/) + else + lo_offset = (/offset_x%beg, offset_y%beg, offset_z%beg/) + hi_offset = (/offset_x%end, offset_y%end, offset_z%end/) + end if - character(LEN=15) :: FMT - character(LEN=3) :: status + 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/) + 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/) + end if + else + lo_offset = (/offset_x%beg, offset_y%beg/) + hi_offset = (/offset_x%end, offset_y%end/) - character(LEN= & - int(floor(log10(real(sys_size, kind(0d0))))) + 1) :: file_num !< Used to store - !! the number, in character form, of the currently - !! manipulated conservative variable data file + dims = (/m + offset_x%beg + offset_x%end + 2, & + n + offset_y%beg + offset_y%end + 2/) + end if + end if - character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< - !! Generic string used to store the address of a particular file + ! Generating Silo-HDF5 Directory Tree ============================== - integer :: i, j, k, l, r, c !< Generic loop iterator - integer :: t_step + if (format == 1) then - real(kind(0d0)), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(kind(0d0)) :: nbub !< Temporary bubble number density - real(kind(0d0)) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(kind(0d0)) :: rho !< Temporary density - real(kind(0d0)) :: pres !< Temporary pressure + ! Creating the directory associated with the local process + dbdir = trim(case_dir)//'/silo_hdf5' - real(kind(0d0)) :: nR3 - real(kind(0d0)) :: ntmp + write (proc_rank_dir, '(A,I0)') '/p', proc_rank - real(kind(0d0)) :: rhoYks(1:num_species) !< Temporary species mass fractions + proc_rank_dir = trim(dbdir)//trim(proc_rank_dir) - t_step = 0 + file_loc = trim(proc_rank_dir)//'/.' - ! Outputting the Locations of the Cell-boundaries ================== + !INQUIRE( DIRECTORY = TRIM(file_loc), & ! Intel compiler + !EXIST = dir_check ) + ! INQUIRE( FILE = TRIM(file_loc), & ! NAG/PGI/GCC compiler + ! EXIST = dir_check ) + call my_inquire(file_loc, dir_check) + if (dir_check .neqv. .true.) then + call s_create_directory(trim(proc_rank_dir)) + end if - if (old_grid) then - status = 'old' - else - status = 'new' - end if + ! Creating the directory associated with the root process + if (proc_rank == 0) then + + rootdir = trim(dbdir)//'/root' + + file_loc = trim(rootdir)//'/.' + + !INQUIRE( DIRECTORY = TRIM(file_loc), & ! Intel compiler + ! EXIST = dir_check ) + ! INQUIRE( FILE = TRIM(file_loc), & ! NAG/PGI/GCC compiler + ! EXIST = dir_check ) + call my_inquire(file_loc, dir_check) + if (dir_check .neqv. .true.) then + call s_create_directory(trim(rootdir)) + end if - ! x-coordinate direction - file_loc = trim(t_step_dir)//'/x_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', STATUS=status) - write (1) x_cb(-1:m) - close (1) - - ! y- and z-coordinate directions - if (n > 0) then - ! y-coordinate direction - file_loc = trim(t_step_dir)//'/y_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) - write (1) y_cb(-1:n) - close (1) - - ! z-coordinate direction - if (p > 0) then - file_loc = trim(t_step_dir)//'/z_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) - write (1) z_cb(-1:p) - close (1) end if - end if - ! ================================================================== + ! ================================================================== - ! Outputting IB Markers ================================ - file_loc = trim(t_step_dir)//'/ib.dat' + ! Generating Binary Directory Tree ================================= - open (1, FILE=trim(file_loc), FORM='unformatted', STATUS=status) - write (1) ib_markers%sf - close (1) + else - if (ib) then - do i = 1, num_ibs - if (patch_ib(i)%geometry == 4) then + ! Creating the directory associated with the local process + dbdir = trim(case_dir)//'/binary' - file_loc = trim(t_step_dir)//'/airfoil_u.dat' + write (proc_rank_dir, '(A,I0)') '/p', proc_rank - open (1, FILE=trim(file_loc), FORM='unformatted', STATUS=status) - write (1) airfoil_grid_u(1:Np) - close (1) + proc_rank_dir = trim(dbdir)//trim(proc_rank_dir) - file_loc = trim(t_step_dir)//'/airfoil_l.dat' + file_loc = trim(proc_rank_dir)//'/.' - open (1, FILE=trim(file_loc), FORM='unformatted', STATUS=status) - write (1) airfoil_grid_l(1:Np) - close (1) - end if - end do - end if - ! ================================================================== + !INQUIRE( DIRECTORY = TRIM(file_loc), & ! Intel compiler + ! EXIST = dir_check ) + ! INQUIRE( FILE = TRIM(file_loc), & ! NAG/PGI/GCC compiler + ! EXIST = dir_check ) + call my_inquire(file_loc, dir_check) - ! 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 - 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) - close (1) - end do - end do + if (dir_check .neqv. .true.) then + call s_create_directory(trim(proc_rank_dir)) + end if - 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) - close (1) - end do - end do - end if - ! ================================================================== + ! Creating the directory associated with the root process + if (n == 0 .and. proc_rank == 0) then - gamma = fluid_pp(1)%gamma - lit_gamma = 1d0/fluid_pp(1)%gamma + 1d0 - pi_inf = fluid_pp(1)%pi_inf - qv = fluid_pp(1)%qv + rootdir = trim(dbdir)//'/root' - if (precision == 1) then - FMT = "(2F30.3)" - else - FMT = "(2F40.14)" - end if + file_loc = trim(rootdir)//'/.' - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/D' - file_loc = trim(t_step_dir)//'/.' + !INQUIRE( DIRECTORY = TRIM(file_loc), & ! Intel compiler + ! EXIST = dir_check ) + ! INQUIRE( FILE = TRIM(file_loc), & ! NAG/PGI/GCC compiler + ! EXIST = dir_check ) + call my_inquire(file_loc, dir_check) - inquire (FILE=trim(file_loc), EXIST=file_exist) + if (dir_check .neqv. .true.) then + call s_create_directory(trim(rootdir)) + end if - if (.not. file_exist) call s_create_directory(trim(t_step_dir)) + end if - if (cfl_dt) t_step = n_start + end if - !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' + ! ================================================================== - open (2, FILE=trim(file_loc)) - do j = 0, m + ! 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 - if (chemistry) then - do c = 1, num_species - rhoYks(c) = q_cons_vf(chemxb + c - 1)%sf(j, 0, 0) - end do - end if + ! Querying Number of Flow Variable(s) in Binary Output ============= - call s_convert_to_mixture_variables(q_cons_vf, j, 0, 0, rho, gamma, pi_inf, qv) - - lit_gamma = 1d0/gamma + 1d0 - - 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)) & - .or. & - ((i == tempxb)) & - ) then - write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) - else if (i == mom_idx%beg) then !u - write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg)%sf(j, 0, 0)/rho - 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 - call s_compute_pressure( & - q_cons_vf(E_idx)%sf(j, 0, 0), & - q_cons_vf(alf_idx)%sf(j, 0, 0), & - 0.5d0*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2.d0)/rho, & - pi_inf, gamma, rho, qv, rhoYks, pres) - write (2, FMT) x_cb(j), pres - else if ((i >= bub_idx%beg) .and. (i <= bub_idx%end) .and. bubbles) then - - if (qbmm) then - nbub = q_cons_vf(bubxb)%sf(j, 0, 0) - else - if (adv_n) then - nbub = q_cons_vf(n_idx)%sf(j, 0, 0) - else - do k = 1, nb - nRtmp(k) = q_cons_vf(bub_idx%rs(k))%sf(j, 0, 0) - end do - - call s_comp_n_from_cons(q_cons_vf(alf_idx)%sf(j, 0, 0), nRtmp, nbub, weight) - end if - end if - write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0)/nbub - else if (i == n_idx .and. adv_n .and. bubbles) then - write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) - end if - end do - close (2) + 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 + dbvars = dbvars + 1 + end if end do 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' + ! Density + if (rho_wrt & + .or. & + (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & + then + dbvars = dbvars + 1 + end if - open (2, FILE=trim(file_loc)) - do j = 0, m - write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) - end do - close (2) + ! Momentum + do i = 1, E_idx - mom_idx%beg + if (mom_wrt(i) .or. cons_vars_wrt) dbvars = dbvars + 1 end do - 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' + ! Velocity + do i = 1, E_idx - mom_idx%beg + if (vel_wrt(i) .or. prim_vars_wrt) dbvars = dbvars + 1 + end do - open (2, FILE=trim(file_loc)) - do j = 0, m - write (2, FMT) x_cb(j), pb%sf(j, 0, 0, r, i) - end do - close (2) - end do - 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' + ! Flux limiter function + do i = 1, E_idx - mom_idx%beg + if (flux_wrt(i)) dbvars = dbvars + 1 + end do - open (2, FILE=trim(file_loc)) - do j = 0, m - write (2, FMT) x_cb(j), mv%sf(j, 0, 0, r, i) - end do - close (2) - end do + ! Energy + if (E_wrt .or. cons_vars_wrt) dbvars = dbvars + 1 + + ! Pressure + if (pres_wrt .or. prim_vars_wrt) dbvars = dbvars + 1 + + ! 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 + dbvars = dbvars + 1 + end if end do + + if (alpha_wrt(num_fluids) & + .or. & + (cons_vars_wrt .or. prim_vars_wrt)) & + then + dbvars = dbvars + 1 + end if + end if - end if - if (precision == 1) then - FMT = "(3F30.7)" - else - FMT = "(3F40.14)" - end if + ! Specific heat ratio function + if (gamma_wrt & + .or. & + (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & + then + dbvars = dbvars + 1 + end if - ! 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' - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - write (2, FMT) x_cb(j), y_cb(k), q_cons_vf(i)%sf(j, k, 0) - end do - write (2, *) - end do - close (2) - end do - 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' - - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - write (2, FMT) x_cb(j), y_cb(k), pb%sf(j, k, 0, r, i) - end do - end do - close (2) - end do - 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' - - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - write (2, FMT) x_cb(j), y_cb(k), mv%sf(j, k, 0, r, i) - end do - end do - close (2) - end do - end do + ! Specific heat ratio + if (heat_ratio_wrt) dbvars = dbvars + 1 + + ! Liquid stiffness function + if (pi_inf_wrt & + .or. & + (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & + then + dbvars = dbvars + 1 end if - end if - if (precision == 1) then - FMT = "(4F30.7)" - else - FMT = "(4F40.14)" - end if + ! Liquid stiffness + if (pres_inf_wrt) dbvars = dbvars + 1 - ! 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' - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - do l = 0, p - write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_cons_vf(i)%sf(j, k, l) - end do - write (2, *) - end do - write (2, *) - end do - close (2) - end do - 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' - - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - do l = 0, p - write (2, FMT) x_cb(j), y_cb(k), z_cb(l), pb%sf(j, k, l, r, i) - end do - end do - end do - close (2) - end do + ! Speed of sound + if (c_wrt) dbvars = dbvars + 1 + + ! Vorticity + if (p > 0) then + do i = 1, E_idx - mom_idx%beg + if (omega_wrt(i)) dbvars = dbvars + 1 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' - - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - do l = 0, p - write (2, FMT) x_cb(j), y_cb(k), z_cb(l), mv%sf(j, k, l, r, i) - end do - end do - end do - close (2) - end do + elseif (n > 0) then + do i = 1, E_idx - cont_idx%end + if (omega_wrt(i)) dbvars = dbvars + 1 end do end if - end if - if (ib) then + ! Numerical Schlieren function + if (schlieren_wrt) dbvars = dbvars + 1 - do i = 1, num_ibs + end if - write (file_loc, '(A,I2.2,A)') trim(t_step_dir)//'/ib_markers.', proc_rank, '.dat' - open (2, FILE=trim(file_loc)) - do j = 0, m - do k = 0, n - do l = 0, p - if (p > 0) then - write (2, FMT) x_cc(j), y_cc(k), z_cc(l), real(ib_markers%sf(j, k, l)) - else - write (2, FMT) x_cc(j), y_cc(k), real(ib_markers%sf(j, k, l)) - end if - end do - end do - end do + ! END: Querying Number of Flow Variable(s) in Binary Output ======== - close (2) - end do - end if + end subroutine s_initialize_data_output_module - if (ib) then - do i = 1, num_ibs - if (patch_ib(i)%geometry == 4) then + 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 + + ! Silo-HDF5 Database Format ======================================== + + if (format == 1) then + + ! Generating the relative path to the formatted database slave + ! file, that is to be opened for the current time-step, t_step + write (file_loc, '(A,I0,A)') '/', t_step, '.silo' + file_loc = trim(proc_rank_dir)//trim(file_loc) + + ! 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', 8, & + DB_HDF5, dbfile) + + ! Verifying that the creation and setup process of the formatted + ! database slave file has been performed without errors. If this + ! is not the case, the post-process exits. + if (dbfile == -1) then + call s_mpi_abort('Unable to create Silo-HDF5 database '// & + 'slave file '//trim(file_loc)//'. '// & + 'Exiting ...') + end if - write (file_loc, '(A,I2.2,A)') trim(t_step_dir)//'/airfoil_u.', proc_rank, '.dat' - open (2, FILE=trim(file_loc)) - do j = 1, Np - write (2, FMT) airfoil_grid_u(j)%x, airfoil_grid_u(j)%y - end do - close (2) + ! 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,I2.2,A)') trim(t_step_dir)//'/airfoil_l.', proc_rank, '.dat' - open (2, FILE=trim(file_loc)) - do j = 1, Np - write (2, FMT) airfoil_grid_l(j)%x, airfoil_grid_l(j)%y - end do - close (2) + write (file_loc, '(A,I0,A)') '/collection_', t_step, '.silo' + file_loc = trim(rootdir)//trim(file_loc) + + ierr = DBCREATE(trim(file_loc), len_trim(file_loc), & + DB_CLOBBER, DB_LOCAL, 'MFC', 8, & + DB_HDF5, dbroot) - print *, "Np", Np + if (dbroot == -1) then + call s_mpi_abort('Unable to create Silo-HDF5 database '// & + 'master file '//trim(file_loc)//'. '// & + 'Exiting ...') end if - end do - end if - end subroutine s_write_serial_data_files + end if - !> 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 ib_markers track if a cell is within the immersed boundary - subroutine s_write_parallel_data_files(q_cons_vf, ib_markers) + ! ================================================================== - ! Conservative variables - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_cons_vf + ! Binary Database Format =========================================== - ! IB markers - type(integer_field), & - intent(in) :: ib_markers + else -#ifdef MFC_MPI + ! Generating the relative path to the formatted database slave + ! file, that is to be opened for the current time-step, t_step + write (file_loc, '(A,I0,A)') '/', t_step, '.dat' + file_loc = trim(proc_rank_dir)//trim(file_loc) + + ! Creating the formatted database slave file, at the previously + ! precised relative path location, and setting up its structure + open (dbfile, IOSTAT=err, FILE=trim(file_loc), & + FORM='unformatted', STATUS='replace') + + ! Verifying that the creation and setup process of the formatted + ! database slave file has been performed without errors. If this + ! is not the case, the post-process exits. + if (err /= 0) then + call s_mpi_abort('Unable to create Binary database slave '// & + 'file '//trim(file_loc)//'. Exiting ...') + end if - 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 + ! 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 + write (dbfile) m, n, p, dbvars - character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist, dir_check + ! 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 - ! Generic loop iterator - integer :: i + write (file_loc, '(A,I0,A)') '/', t_step, '.dat' + file_loc = trim(rootdir)//trim(file_loc) - if (file_per_process) then - if (proc_rank == 0) then - 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)) + 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 ...') end if - call s_create_directory(trim(file_loc)) - end if - call s_mpi_barrier() - call DelayFileAccess(proc_rank) - ! 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 + write (dbroot) m_root, 0, 0, dbvars - ! 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) - 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) - - ! 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) - str_MOK = int(name_len, MPI_OFFSET_KIND) - NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - - ! Write the data for each variable - if (bubbles) then - do i = 1, sys_size! adv_idx%end - var_MOK = int(i, MPI_OFFSET_KIND) - - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, 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_DOUBLE_PRECISION, status, ierr) - end do - end if - else - do i = 1, sys_size !TODO: check if this is right - ! do i = 1, adv_idx%end - var_MOK = int(i, MPI_OFFSET_KIND) + end if - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) - end do - end if + ! END: Binary Database Format ====================================== + + end subroutine s_open_formatted_database_file + + 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 - call MPI_FILE_CLOSE(ifile, ierr) + ! Generic loop iterator + integer :: i - else - ! 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 + ! Silo-HDF5 Database Format ======================================== + + if (format == 1 .and. n > 0) then + + ! For multidimensional data sets, the spatial extents of all of + ! the grid(s) handled by the local processor(s) are recorded so + ! that they may be written, by root processor, to the formatted + ! database master file. + if (num_procs > 1) then + call s_mpi_gather_spatial_extents(spatial_extents) + + elseif (p > 0) then + 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)/) + else + spatial_extents(:, 0) = (/minval(x_cb), minval(y_cb), & + minval(z_cb), maxval(x_cb), & + maxval(y_cb), maxval(z_cb)/) + end if - ! 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) - 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) + spatial_extents(:, 0) = (/minval(x_cb), minval(y_cb), & + maxval(x_cb), maxval(y_cb)/) + end if - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) - - ! Size of local arrays - data_size = (m + 1)*(n + 1)*(p + 1) - - ! Resize some integers so MPI can write even the biggest files - m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) - n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) - p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) - str_MOK = int(name_len, MPI_OFFSET_KIND) - NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - - ! Write the data for each variable - if (bubbles) then - do i = 1, sys_size! adv_idx%end - var_MOK = int(i, MPI_OFFSET_KIND) - - ! Initial displacement to skip at beginning of file - disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, 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_DOUBLE_PRECISION, 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_DOUBLE_PRECISION, 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_DOUBLE_PRECISION, status, ierr) - end do - end if - else - do i = 1, sys_size !TODO: check if this is right - ! do i = 1, adv_idx%end - var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file - disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) + ! 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 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, 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_DOUBLE_PRECISION, status, ierr) + do i = 1, num_procs + write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & + '/', t_step, '.silo:rectilinear_grid' end do - end if - call MPI_FILE_CLOSE(ifile, ierr) - end if + meshtypes = DB_QUAD_RECT - if (ib) then + err = DBSET2DSTRLEN(len(meshnames(1))) + err = DBMKOPTLIST(2, optlist) + err = DBADDIOPT(optlist, DBOPT_EXTENTS_SIZE, & + size(spatial_extents, 1)) + err = DBADDDOPT(optlist, DBOPT_EXTENTS, spatial_extents) + err = DBPUTMMESH(dbroot, 'rectilinear_grid', 16, & + num_procs, meshnames, & + len_trim(meshnames), & + meshtypes, optlist, ierr) + err = DBFREEOPTLIST(optlist) - write (file_loc, '(A)') 'ib.dat' - 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) - ! Initial displacement to skip at beginning of file - disp = 0 + ! 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. - 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) + if (precision == 1) then + if (p > 0) then + do i = -1 - offset_z%beg, p + offset_z%end + z_cb_s(i) = real(z_cb(i)) + end do + else + do i = -1 - offset_x%beg, m + offset_x%end + x_cb_s(i) = real(x_cb(i)) + end do - call MPI_FILE_CLOSE(ifile, ierr) - end if + do i = -1 - offset_y%beg, n + offset_y%end + y_cb_s(i) = real(y_cb(i)) + end do + end if + end if - if (ib) then + #:for PRECISION, SFX, DBT in [(1,'_s','DB_FLOAT'),(2,'',"DB_DOUBLE")] + if (precision == ${PRECISION}$) then + 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${SFX}$, z_cb${SFX}$, x_cb${SFX}$, dims, 3, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + else + err = DBPUTQM(dbfile, 'rectilinear_grid', 16, & + 'x', 1, 'y', 1, 'z', 1, & + x_cb${SFX}$, y_cb${SFX}$, z_cb${SFX}$, dims, 3, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + end if + 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${SFX}$, y_cb${SFX}$, DB_F77NULL, dims, 2, & + ${DBT}$, DB_COLLINEAR, & + optlist, ierr) + err = DBFREEOPTLIST(optlist) + end if + end if + #:endfor + ! END: Silo-HDF5 Database Format =================================== - do i = 1, num_ibs + ! Binary Database Format =========================================== - if (patch_ib(i)%geometry == 4) then + elseif (format == 2) then - write (file_loc, '(A)') 'airfoil_l.dat' - 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) + ! 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, kind(0.0)), & + real(y_cb, kind(0.0)), & + real(z_cb, kind(0.0)) + else + write (dbfile) x_cb, y_cb, z_cb + end if + + elseif (n > 0) then + if (precision == 1) then + write (dbfile) real(x_cb, kind(0.0)), & + real(y_cb, kind(0.0)) + else + write (dbfile) x_cb, y_cb + end if - ! Initial displacement to skip at beginning of file - disp = 0 + ! 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 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(1), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_airfoil_IB_DATA%var(1:Np), 3*Np, & - MPI_DOUBLE_PRECISION, status, ierr) + if (precision == 1) then + write (dbfile) real(x_cb, kind(0.0)) + else + write (dbfile) x_cb + end if - call MPI_FILE_CLOSE(ifile, ierr) + if (num_procs > 1) then + call s_mpi_defragment_1d_grid_variable() + else + x_root_cb = x_cb + end if - write (file_loc, '(A)') 'airfoil_u.dat' - 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) + if (proc_rank == 0) then + if (precision == 1) then + write (dbroot) real(x_root_cb, kind(0.0)) + else + write (dbroot) x_root_cb end if - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + end if + + end if + + end if + + ! ================================================================== - ! Initial displacement to skip at beginning of file - disp = 0 + end subroutine s_write_grid_to_formatted_database_file + + 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 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(2), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_airfoil_IB_DATA%var(Np + 1:2*Np), 3*Np, & - MPI_DOUBLE_PRECISION, status, ierr) + ! Generic loop iterator + integer :: i, j, k + real(wp) :: start, finish + + ! Silo-HDF5 Database Format ======================================== + + if (format == 1) then + + ! In 1D, a curve object, featuring the local processor grid and + ! flow variable data, is written to the formatted database slave + ! file. The root process, on the other hand, will also take care + ! of gathering the entire grid and associated flow variable data + ! and write it to the formatted database master file. + if (n == 0) then + + ! Writing the curve object associated with the local process + ! to the formatted database slave file + err = DBPUTCURVE(dbfile, trim(varname), len_trim(varname), & + x_cc(0:m), q_sf, DB_DOUBLE, m + 1, & + DB_F77NULL, ierr) + + ! Assembling the local grid and flow variable data for the + ! entire computational domain on to the root process + if (num_procs > 1) then + call s_mpi_defragment_1d_grid_variable() + call s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) + else + x_root_cc = x_cc(0:m) + q_root_sf = q_sf + end if - call MPI_FILE_CLOSE(ifile, ierr) + ! Writing the curve object associated with the root process + ! to the formatted database master file + if (proc_rank == 0) then + err = DBPUTCURVE(dbroot, trim(varname), & + len_trim(varname), & + x_root_cc, q_root_sf, & + DB_DOUBLE, m_root + 1, & + DB_F77NULL, ierr) end if - end do - end if -#endif + return - end subroutine s_write_parallel_data_files + ! In multidimensions, the local process(es) take care of writing + ! the flow variable data they are in charge of to the formatted + ! database slave file. The root processor, additionally, is also + ! responsible in gathering the flow variable extents of each of + ! the local processor(s) and writing them to formatted database + ! master file. + else - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module - 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) :: coord = (/'x', 'y', 'z'/) + ! Determining the extents of the flow variable on each local + ! process and gathering all this information on root process + if (num_procs > 1) then + call s_mpi_gather_data_extents(q_sf, data_extents) + else + data_extents(:, 0) = (/minval(q_sf), maxval(q_sf)/) + end if - ! Generic logical used to check the existence of directories - logical :: dir_check - integer :: i + ! Next, the root process proceeds to write the gathered flow + ! variable data extents to formatted database master file. + if (proc_rank == 0) then - 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) + do i = 1, num_procs + write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & + '/', t_step, '.silo:'//trim(varname) + end do - ! 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 + vartypes = DB_QUADVAR - file_loc = trim(t_step_dir)//'/' + err = DBSET2DSTRLEN(len(varnames(1))) + err = DBMKOPTLIST(2, optlist) + err = DBADDIOPT(optlist, DBOPT_EXTENTS_SIZE, 2) + err = DBADDDOPT(optlist, DBOPT_EXTENTS, data_extents) + err = DBPUTMVAR(dbroot, trim(varname), & + len_trim(varname), num_procs, & + varnames, len_trim(varnames), & + vartypes, optlist, ierr) + err = DBFREEOPTLIST(optlist) - call my_inquire(file_loc, dir_check) + 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 (precision == 1) 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 + q_sf_s(i, j, k) = real(q_sf(i, j, k)) + end do + end do + end do + end if - if (dir_check) call s_delete_directory(trim(t_step_dir)) + if (grid_geometry == 3) 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 + cyl_q_sf(j, k, i) = q_sf(i, j, k) + end do + end do + end do + end if - call s_create_directory(trim(t_step_dir)) + #:for PRECISION, SFX, DBT in [(1,'_s','DB_FLOAT'),(2,'',"DB_DOUBLE")] + 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) + 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) + end if + else + 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) + end if + end if + #:endfor 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) + ! END: Silo-HDF5 Database Format =================================== - if ((old_grid .neqv. .true.) .and. (proc_rank == 0)) then + ! Binary Database Format =========================================== - file_loc = trim(restart_dir)//'/' - call my_inquire(file_loc, dir_check) + else - if (dir_check) call s_delete_directory(trim(restart_dir)) - call s_create_directory(trim(restart_dir)) + ! 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, kind(0.0)) + else + write (dbfile) varname, q_sf end if - call s_mpi_barrier() + ! 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 - s_write_data_files => s_write_parallel_data_files + if (num_procs > 1) then + call s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) + else + q_root_sf = q_sf + end if - end if + if (proc_rank == 0) then + if (precision == 1) then + write (dbroot) varname, real(q_root_sf, kind(0.0)) + else + write (dbroot) varname, q_root_sf + end if + end if + + end if - open (1, FILE='indices.dat', STATUS='unknown') - - write (1, '(A)') "Warning: The creation of file is currently experimental." - write (1, '(A)') "This file may contain errors and not support all features." - - write (1, '(A3,A20,A20)') "#", "Conservative", "Primitive" - 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" - end do - do i = momxb, momxe - 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)//"}" - 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))//"}" - end do end if - write (1, '(A)') "" - if (momxb /= 0) write (1, '("[",I2,",",I2,"]",A)') momxb, momxe, " Momentum" - if (E_idx /= 0) write (1, '("[",I2,",",I2,"]",A)') E_idx, E_idx, " Energy/Pressure" - if (advxb /= 0) write (1, '("[",I2,",",I2,"]",A)') advxb, advxe, " Advection" - if (contxb /= 0) write (1, '("[",I2,",",I2,"]",A)') contxb, contxe, " Continuity" - if (bubxb /= 0) write (1, '("[",I2,",",I2,"]",A)') bubxb, bubxe, " Bubbles" - if (strxb /= 0) write (1, '("[",I2,",",I2,"]",A)') strxb, strxe, " Stress" - if (intxb /= 0) write (1, '("[",I2,",",I2,"]",A)') intxb, intxe, " Internal Energies" - if (chemxb /= 0) write (1, '("[",I2,",",I2,"]",A)') chemxb, chemxe, " Chemistry" - if (tempxb /= 0) write (1, '("[",I2,",",I2,"]",A)') tempxb, tempxe, " Temperature" + ! ================================================================== - close (1) + end subroutine s_write_variable_to_formatted_database_file + + 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. + + ! Silo-HDF5 database format + 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 subroutine s_initialize_data_output_module + end if + + end subroutine s_close_formatted_database_file - !> Resets s_write_data_files pointer 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 - s_write_data_files => null() + ! 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 .and. n > 0) then + deallocate (spatial_extents) + deallocate (data_extents) + deallocate (lo_offset) + deallocate (hi_offset) + deallocate (dims) + end if end subroutine s_finalize_data_output_module -end module m_data_output +end module m_data_output \ No newline at end of file diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 6f15347bd2..f2fbc18a7c 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -53,13 +53,13 @@ module m_global_parameters logical :: cyl_coord integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) - real(kind(0d0)), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< + real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< !! Locations of cell-centers (cc) in x-, y- and z-directions, respectively - real(kind(0d0)), allocatable, dimension(:) :: x_cb, y_cb, z_cb !< + real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb !< !! Locations of cell-boundaries (cb) in x-, y- and z-directions, respectively - real(kind(0d0)) :: dx, dy, dz !< + 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 !< @@ -72,10 +72,10 @@ module m_global_parameters ! directions. The "a" parameters are a measure of the rate at which the grid ! is stretched while the remaining parameters are indicative of the location ! on the grid at which the stretching begins. - real(kind(0d0)) :: a_x, a_y, a_z + real(wp) :: a_x, a_y, a_z integer :: loops_x, loops_y, loops_z - real(kind(0d0)) :: x_a, y_a, z_a - real(kind(0d0)) :: x_b, y_b, z_b + real(wp) :: x_a, y_a, z_a + real(wp) :: x_b, y_b, z_b ! ========================================================================== @@ -83,8 +83,8 @@ module m_global_parameters integer :: model_eqns !< Multicomponent flow model logical :: relax !< activate phase change integer :: relax_model !< Relax Model - real(kind(0d0)) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(kind(0d0)) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change 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 @@ -116,19 +116,19 @@ module m_global_parameters integer :: precision !< Precision of output files logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile - real(kind(0d0)) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - real(kind(0d0)) :: mixlayer_domain !< Domain for the hyperbolic tangent streamwise velocity profile + real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile + real(wp) :: mixlayer_domain !< Domain for the hyperbolic tangent streamwise velocity profile logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow - real(kind(0d0)) :: pi_fac !< Factor for artificial pi_inf + real(wp) :: pi_fac !< Factor for artificial pi_inf ! 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(kind(0d0)) :: perturb_flow_mag !< Magnitude of perturbation 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(kind(0d0)), dimension(num_fluids_max) :: fluid_rho + real(wp), dimension(num_fluids_max) :: fluid_rho integer, allocatable, dimension(:) :: proc_coords !< !! Processor coordinates in MPI_CART_COMM @@ -169,18 +169,18 @@ module m_global_parameters ! ========================================================================== - real(kind(0d0)) :: rhoref, pref !< Reference parameters for Tait EOS + real(wp) :: rhoref, pref !< Reference parameters for Tait EOS !> @name Bubble modeling !> @{ integer :: nb - real(kind(0d0)) :: R0ref - real(kind(0d0)) :: Ca, Web, Re_inv - real(kind(0d0)), dimension(:), allocatable :: weight, R0, V0 + real(wp) :: R0ref + real(wp) :: Ca, Web, Re_inv + real(wp), dimension(:), allocatable :: weight, R0, V0 logical :: bubbles logical :: qbmm !< Quadrature moment method integer :: nmom !< Number of carried moments - real(kind(0d0)) :: sigR, sigV, rhoRV !< standard deviations in R/V + real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V logical :: adv_n !< Solve the number density equation and compute alpha from number density !> @} @@ -206,19 +206,19 @@ module m_global_parameters logical :: polytropic logical :: polydisperse integer :: thermal !1 = adiabatic, 2 = isotherm, 3 = transfer - real(kind(0d0)) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v - real(kind(0d0)), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T - real(kind(0d0)), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - real(kind(0d0)) :: mul0, ss, gamma_v, mu_v - real(kind(0d0)) :: gamma_m, gamma_n, mu_n - real(kind(0d0)) :: poly_sigma + real(wp) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v + real(wp), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T + real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN + real(wp) :: mul0, ss, gamma_v, mu_v + real(wp) :: gamma_m, gamma_n, mu_n + real(wp) :: poly_sigma integer :: dist_type !1 = binormal, 2 = lognormal-normal integer :: R0_type !1 = simpson !> @} !> @name Surface Tension Modeling !> @{ - real(kind(0d0)) :: sigma + real(wp) :: sigma !> @} !> @name Index variables used for m_variables_conversion @@ -305,8 +305,8 @@ contains #:for DIM in ['x', 'y', 'z'] #:for DIR in [1, 2, 3] - bc_${DIM}$%vb${DIR}$ = 0d0 - bc_${DIM}$%ve${DIR}$ = 0d0 + bc_${DIM}$%vb${DIR}$ = 0._wp + bc_${DIM}$%ve${DIR}$ = 0._wp #:endfor #:endfor @@ -314,8 +314,8 @@ contains file_per_process = .false. precision = 2 mixlayer_vel_profile = .false. - mixlayer_vel_coef = 1d0 - mixlayer_domain = 1d0 + mixlayer_vel_coef = 1._wp + mixlayer_domain = 1._wp mixlayer_perturb = .false. perturb_flow = .false. perturb_flow_fluid = dflt_int @@ -329,11 +329,11 @@ contains do i = 1, num_patches_max patch_icpp(i)%geometry = dflt_int - patch_icpp(i)%model%scale(:) = 1d0 - patch_icpp(i)%model%translate(:) = 0d0 + patch_icpp(i)%model%scale(:) = 1._wp + patch_icpp(i)%model%translate(:) = 0._wp patch_icpp(i)%model%filepath(:) = ' ' patch_icpp(i)%model%spc = 10 - patch_icpp(i)%model%threshold = 0.9d0 + patch_icpp(i)%model%threshold = 0.9_wp patch_icpp(i)%x_centroid = dflt_real patch_icpp(i)%y_centroid = dflt_real patch_icpp(i)%z_centroid = dflt_real @@ -357,10 +357,10 @@ contains patch_icpp(i)%alpha = dflt_real patch_icpp(i)%gamma = dflt_real patch_icpp(i)%pi_inf = dflt_real - patch_icpp(i)%cv = 0d0 - patch_icpp(i)%qv = 0d0 - patch_icpp(i)%qvp = 0d0 - patch_icpp(i)%tau_e = 0d0 + patch_icpp(i)%cv = 0._wp + patch_icpp(i)%qv = 0._wp + patch_icpp(i)%qvp = 0._wp + patch_icpp(i)%tau_e = 0._wp !should get all of r0's and v0's patch_icpp(i)%r0 = dflt_real patch_icpp(i)%v0 = dflt_real @@ -399,7 +399,7 @@ contains nmom = 1 sigR = dflt_real sigV = dflt_real - rhoRV = 0d0 + rhoRV = 0._wp dist_type = dflt_int R0_type = dflt_int @@ -412,7 +412,7 @@ contains ! surface tension modeling sigma = dflt_real - pi_fac = 1d0 + pi_fac = 1._wp ! Immersed Boundaries ib = .false. @@ -446,10 +446,10 @@ contains fluid_pp(i)%M_v = dflt_real fluid_pp(i)%mu_v = dflt_real fluid_pp(i)%k_v = dflt_real - fluid_pp(i)%cv = 0d0 - fluid_pp(i)%qv = 0d0 - fluid_pp(i)%qvp = 0d0 - fluid_pp(i)%G = 0d0 + fluid_pp(i)%cv = 0._wp + fluid_pp(i)%qv = 0._wp + fluid_pp(i)%qvp = 0._wp + fluid_pp(i)%G = 0._wp end do end subroutine s_assign_default_values_to_user_inputs @@ -568,11 +568,11 @@ contains end if if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 1d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 1._wp else if (nb > 1) then - V0(:) = 1d0 + V0(:) = 1._wp !R0 and weight initialized in s_simpson else stop 'Invalid value of nb' @@ -581,8 +581,8 @@ contains !Initialize pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) if (.not. qbmm) then if (polytropic) then - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if @@ -593,9 +593,9 @@ contains if ((f_is_default(Web))) then pb0 = pref pb0 = pb0/pref - pref = 1d0 + pref = 1._wp end if - rhoref = 1d0 + rhoref = 1._wp end if end if end if @@ -678,18 +678,18 @@ contains end do if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 0d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 0._wp else if (nb > 1) then - V0(:) = 1d0 + V0(:) = 1._wp else stop 'Invalid value of nb' end if if (polytropic) then - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 84fdb14f42..9f8e02918e 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -58,14 +58,14 @@ subroutine s_generate_serial_grid ! Generic loop iterator integer :: i, j !< generic loop operators - real(kind(0d0)) :: length !< domain lengths + real(wp) :: length !< domain lengths ! Grid Generation in the x-direction =============================== - dx = (x_domain%end - x_domain%beg)/real(m + 1, kind(0d0)) + dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) do i = 0, m - x_cc(i) = x_domain%beg + 5d-1*dx*real(2*i + 1, kind(0d0)) - x_cb(i - 1) = x_domain%beg + dx*real(i, kind(0d0)) + x_cc(i) = x_domain%beg + 5d-1*dx*real(2*i + 1, wp) + x_cb(i - 1) = x_domain%beg + dx*real(i, wp) end do x_cb(m) = x_domain%end @@ -82,12 +82,12 @@ subroutine s_generate_serial_grid 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))) & - - 2d0*log(cosh(a_x*(x_b - x_a)/2d0))) + - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do x_cb = x_cb*length - x_cc = (x_cb(0:m) + x_cb(-1:m - 1))/2d0 + x_cc = (x_cb(0:m) + x_cb(-1:m - 1))/2._wp dx = minval(x_cb(0:m) - x_cb(-1:m - 1)) print *, 'Stretched grid: min/max x grid: ', minval(x_cc(:)), maxval(x_cc(:)) @@ -99,26 +99,26 @@ subroutine s_generate_serial_grid ! Grid Generation in the y-direction =============================== if (n == 0) return - if (grid_geometry == 2 .and. y_domain%beg == 0.0d0) then + if (grid_geometry == 2 .and. y_domain%beg == 0.0_wp) then !IF (grid_geometry == 2) THEN - dy = (y_domain%end - y_domain%beg)/real(2*n + 1, kind(0d0)) + dy = (y_domain%end - y_domain%beg)/real(2*n + 1, wp) y_cc(0) = y_domain%beg + 5d-1*dy y_cb(-1) = y_domain%beg do i = 1, n - y_cc(i) = y_domain%beg + 2d0*dy*real(i, kind(0d0)) - y_cb(i - 1) = y_domain%beg + dy*real(2*i - 1, kind(0d0)) + 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, kind(0d0)) + dy = (y_domain%end - y_domain%beg)/real(n + 1, wp) do i = 0, n - y_cc(i) = y_domain%beg + 5d-1*dy*real(2*i + 1, kind(0d0)) - y_cb(i - 1) = y_domain%beg + dy*real(i, kind(0d0)) + y_cc(i) = y_domain%beg + 5d-1*dy*real(2*i + 1, wp) + y_cb(i - 1) = y_domain%beg + dy*real(i, wp) end do end if @@ -137,12 +137,12 @@ subroutine s_generate_serial_grid 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))) & - - 2d0*log(cosh(a_y*(y_b - y_a)/2d0))) + - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do y_cb = y_cb*length - y_cc = (y_cb(0:n) + y_cb(-1:n - 1))/2d0 + y_cc = (y_cb(0:n) + y_cb(-1:n - 1))/2._wp dy = minval(y_cb(0:n) - y_cb(-1:n - 1)) @@ -154,11 +154,11 @@ subroutine s_generate_serial_grid ! Grid Generation in the z-direction =============================== if (p == 0) return - dz = (z_domain%end - z_domain%beg)/real(p + 1, kind(0d0)) + dz = (z_domain%end - z_domain%beg)/real(p + 1, wp) do i = 0, p - z_cc(i) = z_domain%beg + 5d-1*dz*real(2*i + 1, kind(0d0)) - z_cb(i - 1) = z_domain%beg + dz*real(i, kind(0d0)) + z_cc(i) = z_domain%beg + 5d-1*dz*real(2*i + 1, wp) + z_cb(i - 1) = z_domain%beg + dz*real(i, wp) end do z_cb(p) = z_domain%end @@ -175,12 +175,12 @@ subroutine s_generate_serial_grid 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))) & - - 2d0*log(cosh(a_z*(z_b - z_a)/2d0))) + - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do z_cb = z_cb*length - z_cc = (z_cb(0:p) + z_cb(-1:p - 1))/2d0 + z_cc = (z_cb(0:p) + z_cb(-1:p - 1))/2._wp dz = minval(z_cb(0:p) - z_cb(-1:p - 1)) @@ -200,10 +200,10 @@ subroutine s_generate_parallel_grid #ifdef MFC_MPI - real(kind(0d0)) :: length !< domain lengths + real(wp) :: length !< domain lengths ! Locations of cell boundaries - real(kind(0d0)), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< + 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 !< @@ -219,9 +219,9 @@ subroutine s_generate_parallel_grid allocate (z_cb_glb(-1:p_glb)) ! Grid generation in the x-direction - dx = (x_domain%end - x_domain%beg)/real(m_glb + 1, kind(0d0)) + 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, kind(0d0)) + x_cb_glb(i - 1) = x_domain%beg + dx*real(i, wp) end do x_cb_glb(m_glb) = x_domain%end if (stretch_x) then @@ -237,7 +237,7 @@ subroutine s_generate_parallel_grid 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))) & - - 2d0*log(cosh(a_x*(x_b - x_a)/2d0))) + - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do @@ -248,16 +248,16 @@ subroutine s_generate_parallel_grid ! Grid generation in the y-direction if (n_glb > 0) then - if (grid_geometry == 2 .and. y_domain%beg == 0.0d0) then - dy = (y_domain%end - y_domain%beg)/real(2*n_glb + 1, kind(0d0)) + if (grid_geometry == 2 .and. 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 do i = 1, n_glb - y_cb_glb(i - 1) = y_domain%beg + dy*real(2*i - 1, kind(0d0)) + y_cb_glb(i - 1) = y_domain%beg + dy*real(2*i - 1, wp) end do else - dy = (y_domain%end - y_domain%beg)/real(n_glb + 1, kind(0d0)) + dy = (y_domain%end - y_domain%beg)/real(n_glb + 1, wp) do i = 0, n_glb - y_cb_glb(i - 1) = y_domain%beg + dy*real(i, kind(0d0)) + y_cb_glb(i - 1) = y_domain%beg + dy*real(i, wp) end do end if y_cb_glb(n_glb) = y_domain%end @@ -274,7 +274,7 @@ subroutine s_generate_parallel_grid 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))) & - - 2d0*log(cosh(a_y*(y_b - y_a)/2d0))) + - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -284,9 +284,9 @@ subroutine s_generate_parallel_grid ! Grid generation in the z-direction if (p_glb > 0) then - dz = (z_domain%end - z_domain%beg)/real(p_glb + 1, kind(0d0)) + dz = (z_domain%end - z_domain%beg)/real(p_glb + 1, wp) do i = 0, p_glb - z_cb_glb(i - 1) = z_domain%beg + dz*real(i, kind(0d0)) + z_cb_glb(i - 1) = z_domain%beg + dz*real(i, wp) end do z_cb_glb(p_glb) = z_domain%end if (stretch_z) then @@ -301,7 +301,7 @@ subroutine s_generate_parallel_grid 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))) & - - 2d0*log(cosh(a_z*(z_b - z_a)/2d0))) + - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -316,7 +316,7 @@ subroutine s_generate_parallel_grid 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_WRITE(ifile, x_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, 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 @@ -324,7 +324,7 @@ subroutine s_generate_parallel_grid 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_WRITE(ifile, y_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, 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 @@ -332,7 +332,7 @@ subroutine s_generate_parallel_grid 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_WRITE(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, 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 diff --git a/src/pre_process/m_model.fpp b/src/pre_process/m_model.fpp index eb54ffb3d3..f4a7fa5dd8 100644 --- a/src/pre_process/m_model.fpp +++ b/src/pre_process/m_model.fpp @@ -454,12 +454,12 @@ contains t_vec3, intent(in) :: spacing integer, intent(in) :: spc - real(kind(0d0)) :: fraction + real(wp) :: fraction type(t_ray) :: ray integer :: i, j, nInOrOut, nHits - real(kind(0d0)), dimension(1:spc, 1:3) :: ray_origins, ray_dirs + real(wp), dimension(1:spc, 1:3) :: ray_origins, ray_dirs do i = 1, spc call random_number(ray_origins(i, :)) @@ -501,8 +501,8 @@ contains logical :: intersects - real(kind(0d0)) :: v0v1(3), v0v2(3), N(3), P(3), C(3), edge(3), vp(3) - real(kind(0d0)) :: area2, d, t, NdotRayDirection + real(wp) :: v0v1(3), v0v2(3), N(3), P(3), C(3), edge(3), vp(3) + real(wp) :: area2, d, t, NdotRayDirection intersects = .false. diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 09c20034e7..a54d23c928 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -69,7 +69,7 @@ contains & 'Web', 'Ca', 'Re_inv', 'sigR', 'sigV', 'rhoRV', 'palpha_eps', & & 'ptgalpha_eps', 'sigma', 'pi_fac', 'mixlayer_vel_coef', & & 'mixlayer_domain' ] - call MPI_BCAST(${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor do i = 1, num_patches_max @@ -85,14 +85,14 @@ contains & 'beta', 'smooth_coeff', 'rho', 'p0', 'm0', 'r0', 'v0', & & 'pres', 'gamma', 'pi_inf', 'hcid', 'cv', 'qv', 'qvp', & & 'model%threshold', 'cf_val'] - call MPI_BCAST(patch_icpp(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(patch_icpp(i)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor call MPI_BCAST(patch_icpp(i)%model%filepath, len(patch_icpp(i)%model%filepath), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in [ 'model%translate', 'model%scale', 'model%rotate', & 'normal', 'radii', 'vel', 'tau_e', 'alpha_rho', 'alpha' ] - call MPI_BCAST(patch_icpp(i)%${VAR}$, size(patch_icpp(i)%${VAR}$), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(patch_icpp(i)%${VAR}$, size(patch_icpp(i)%${VAR}$), mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor call MPI_BCAST(patch_icpp(i)%model%spc, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) @@ -101,7 +101,7 @@ contains call MPI_BCAST(patch_ib(i)%geometry, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) #:for VAR in [ 'x_centroid', 'y_centroid', 'z_centroid', & & 'length_x', 'length_y', 'length_z', 'radius', 'c', 'p', 't', 'm', 'theta', 'slip'] - call MPI_BCAST(patch_ib(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(patch_ib(i)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor end do @@ -109,7 +109,7 @@ contains do i = 1, num_fluids_max #:for VAR in [ 'gamma','pi_inf','mul0','ss','pv','gamma_v','M_v', & & 'mu_v','k_v', 'G', 'cv', 'qv', 'qvp' ] - call MPI_BCAST(fluid_pp(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor end do #endif @@ -130,10 +130,10 @@ contains ! Temporary # of processors in x-, y- and z-coordinate directions ! used during the processor factorization optimization procedure - real(kind(0d0)) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z + real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z ! Processor factorization (fct) minimization parameter - real(kind(0d0)) :: fct_min + real(wp) :: fct_min ! Cartesian processor topology communicator integer :: MPI_COMM_CART @@ -179,8 +179,8 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*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 @@ -223,10 +223,10 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + 10d0*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) ! Searching for optimal computational domain distribution do i = 1, num_procs @@ -305,7 +305,7 @@ contains ! Preliminary uniform cell-width spacing if (old_grid .neqv. .true.) then - dz = (z_domain%end - z_domain%beg)/real(p + 1, kind(0d0)) + dz = (z_domain%end - z_domain%beg)/real(p + 1, wp) end if ! Optimal number of cells per processor @@ -357,8 +357,8 @@ contains ! Computing minimization variable for these initial values tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y - fct_min = 10d0*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 @@ -420,7 +420,7 @@ contains ! Preliminary uniform cell-width spacing if (old_grid .neqv. .true.) then - dy = (y_domain%end - y_domain%beg)/real(n + 1, kind(0d0)) + dy = (y_domain%end - y_domain%beg)/real(n + 1, wp) end if ! Optimal number of cells per processor @@ -489,7 +489,7 @@ contains ! Preliminary uniform cell-width spacing if (old_grid .neqv. .true.) then - dx = (x_domain%end - x_domain%beg)/real(m + 1, kind(0d0)) + dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) end if ! Optimal number of cells per processor diff --git a/src/pre_process/m_patches.fpp b/src/pre_process/m_patches.fpp index 5baf28cc89..0fa1707425 100644 --- a/src/pre_process/m_patches.fpp +++ b/src/pre_process/m_patches.fpp @@ -54,24 +54,24 @@ module m_patches s_sweep_plane, & s_model - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid - real(kind(0d0)) :: length_x, length_y, length_z + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z integer :: smooth_patch_id - real(kind(0d0)) :: smooth_coeff !< + 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(kind(0d0)) :: eta !< + 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(kind(0d0)) :: cart_y, cart_z - real(kind(0d0)) :: sph_phi !< + real(wp) :: 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 @@ -99,13 +99,13 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)) :: pi_inf, gamma, lit_gamma + real(wp) :: pi_inf, gamma, lit_gamma integer :: i, j, k !< Generic loop operators pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the line segment's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -113,14 +113,14 @@ contains ! Computing the beginning and end x-coordinates of the line segment ! based on its centroid and length - x_boundary%beg = x_centroid - 0.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x + 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. - eta = 1d0 + eta = 1._wp ! Checking whether the line segment covers a particular cell in the ! domain and verifying whether the current patch has the permission @@ -137,7 +137,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, 0, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, 0, 0) = patch_id end if end do @@ -158,8 +158,8 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators - real(kind(0d0)) :: th, thickness, nturns, mya - real(kind(0d0)) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max + real(wp) :: th, thickness, nturns, mya + real(wp) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max ! Transferring the circular patch's radius, centroid, smearing patch ! identity and smearing coefficient information @@ -172,16 +172,16 @@ contains ! logic_grid = 0 do k = 0, int(m*91*nturns) - th = k/real(int(m*91d0*nturns))*nturns*2.d0*pi + th = k/real(int(m*91._wp*nturns))*nturns*2._wp*pi - spiral_x_min = minval((/f_r(th, 0.0d0, mya)*cos(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.0d0, mya)*sin(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.0d0, mya)*cos(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.0d0, mya)*sin(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; @@ -201,7 +201,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id end if end do end do @@ -224,7 +224,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf logical, intent(in) :: ib - real(kind(0d0)) :: radius + real(wp) :: radius integer :: i, j, k !< Generic loop iterators @@ -246,7 +246,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smoothing of the circular patch's boundary is enabled. - eta = 1d0 + 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 @@ -261,7 +261,7 @@ contains eta = tanh(smooth_coeff/min(dx, dy)* & (sqrt((x_cc(i) - x_centroid)**2 & + (y_cc(j) - y_centroid)**2) & - - radius))*(-0.5d0) + 0.5d0 + - radius))*(-0.5_wp) + 0.5_wp end if @@ -304,7 +304,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf logical, intent(in) :: ib - real(kind(0d0)) :: x0, y0, f, x_act, y_act, ca, pa, ma, ta, theta, xa, ya, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c + real(wp) :: x0, y0, f, x_act, y_act, ca, pa, ma, ta, theta, xa, ya, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, l integer :: Np1, Np2 @@ -315,7 +315,7 @@ contains pa = patch_ib(patch_id)%p ma = patch_ib(patch_id)%m ta = patch_ib(patch_id)%t - theta = pi*patch_ib(patch_id)%theta/180d0 + theta = pi*patch_ib(patch_id)%theta/180._wp Np1 = int((pa*ca/dx)*20) Np2 = int(((ca - pa*ca)/dx)*20) @@ -330,7 +330,7 @@ contains airfoil_grid_l(1)%x = x0 airfoil_grid_l(1)%y = y0 - eta = 1d0 + eta = 1._wp do i = 1, Np1 + Np2 - 1 if (i <= Np1) then @@ -345,7 +345,7 @@ contains dycdxc = (2*ma/(1 - pa)**2)*(pa - xa) end if - yt = (5d0*ta)*(0.2969*xa**0.5d0 - 0.126*xa - 0.3516*xa**2d0 + 0.2843*xa**3 - 0.1015*xa**4) + yt = (5._wp*ta)*(0.2969*xa**0.5_wp - 0.126*xa - 0.3516*xa**2._wp + 0.2843*xa**3 - 0.1015*xa**4) sin_c = dycdxc/(1 + dycdxc**2)**0.5 cos_c = 1/(1 + dycdxc**2)**0.5 @@ -409,7 +409,7 @@ contains end if else f = (airfoil_grid_u(k)%x - x_act)/(airfoil_grid_u(k)%x - airfoil_grid_u(k - 1)%x) - if (y_act <= ((1d0 - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then + if (y_act <= ((1._wp - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then !!IB !call s_assign_patch_primitive_variables(patch_id, i, j, 0, & !eta, q_prim_vf, patch_id_fp) @@ -431,7 +431,7 @@ contains else f = (airfoil_grid_l(k)%x - x_act)/(airfoil_grid_l(k)%x - airfoil_grid_l(k - 1)%x) - if (y_act >= ((1d0 - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then + if (y_act >= ((1._wp - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then !!IB !call s_assign_patch_primitive_variables(patch_id, i, j, 0, & !eta, q_prim_vf, patch_id_fp) @@ -446,10 +446,10 @@ contains if (.not. f_is_default(patch_ib(patch_id)%theta)) then do i = 1, Np airfoil_grid_l(i)%x = (airfoil_grid_l(i)%x - x0)*cos(theta) + (airfoil_grid_l(i)%y - y0)*sin(theta) + x0 - airfoil_grid_l(i)%y = -1d0*(airfoil_grid_l(i)%x - x0)*sin(theta) + (airfoil_grid_l(i)%y - y0)*cos(theta) + y0 + airfoil_grid_l(i)%y = -1._wp*(airfoil_grid_l(i)%x - x0)*sin(theta) + (airfoil_grid_l(i)%y - y0)*cos(theta) + y0 airfoil_grid_u(i)%x = (airfoil_grid_u(i)%x - x0)*cos(theta) + (airfoil_grid_u(i)%y - y0)*sin(theta) + x0 - airfoil_grid_u(i)%y = -1d0*(airfoil_grid_u(i)%x - x0)*sin(theta) + (airfoil_grid_u(i)%y - y0)*cos(theta) + y0 + airfoil_grid_u(i)%y = -1._wp*(airfoil_grid_u(i)%x - x0)*sin(theta) + (airfoil_grid_u(i)%y - y0)*cos(theta) + y0 end do end if @@ -466,7 +466,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf logical, intent(in) :: ib - real(kind(0d0)) :: x0, y0, z0, lz, z_max, z_min, f, x_act, y_act, ca, pa, ma, ta, theta, xa, ya, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c + real(wp) :: x0, y0, z0, lz, z_max, z_min, f, x_act, y_act, ca, pa, ma, ta, theta, xa, ya, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, l integer :: Np1, Np2 @@ -479,7 +479,7 @@ contains pa = patch_ib(patch_id)%p ma = patch_ib(patch_id)%m ta = patch_ib(patch_id)%t - theta = pi*patch_ib(patch_id)%theta/180d0 + theta = pi*patch_ib(patch_id)%theta/180._wp Np1 = int((pa*ca/dx)*20) Np2 = int(((ca - pa*ca)/dx)*20) @@ -497,7 +497,7 @@ contains z_max = z0 + lz/2 z_min = z0 - lz/2 - eta = 1d0 + eta = 1._wp do i = 1, Np1 + Np2 - 1 if (i <= Np1) then @@ -512,7 +512,7 @@ contains dycdxc = (2*ma/(1 - pa)**2)*(pa - xa) end if - yt = (5d0*ta)*(0.2969*xa**0.5d0 - 0.126*xa - 0.3516*xa**2d0 + 0.2843*xa**3 - 0.1015*xa**4) + yt = (5._wp*ta)*(0.2969*xa**0.5_wp - 0.126*xa - 0.3516*xa**2._wp + 0.2843*xa**3 - 0.1015*xa**4) sin_c = dycdxc/(1 + dycdxc**2)**0.5 cos_c = 1/(1 + dycdxc**2)**0.5 @@ -578,7 +578,7 @@ contains end if else f = (airfoil_grid_u(k)%x - x_act)/(airfoil_grid_u(k)%x - airfoil_grid_u(k - 1)%x) - if (y_act <= ((1d0 - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then + if (y_act <= ((1._wp - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then !!IB !call s_assign_patch_primitive_variables(patch_id, i, j, 0, & !eta, q_prim_vf, patch_id_fp) @@ -600,7 +600,7 @@ contains else f = (airfoil_grid_l(k)%x - x_act)/(airfoil_grid_l(k)%x - airfoil_grid_l(k - 1)%x) - if (y_act >= ((1d0 - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then + if (y_act >= ((1._wp - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then !!IB !call s_assign_patch_primitive_variables(patch_id, i, j, 0, & !eta, q_prim_vf, patch_id_fp) @@ -617,10 +617,10 @@ contains if (.not. f_is_default(patch_ib(patch_id)%theta)) then do i = 1, Np airfoil_grid_l(i)%x = (airfoil_grid_l(i)%x - x0)*cos(theta) + (airfoil_grid_l(i)%y - y0)*sin(theta) + x0 - airfoil_grid_l(i)%y = -1d0*(airfoil_grid_l(i)%x - x0)*sin(theta) + (airfoil_grid_l(i)%y - y0)*cos(theta) + y0 + airfoil_grid_l(i)%y = -1._wp*(airfoil_grid_l(i)%x - x0)*sin(theta) + (airfoil_grid_l(i)%y - y0)*cos(theta) + y0 airfoil_grid_u(i)%x = (airfoil_grid_u(i)%x - x0)*cos(theta) + (airfoil_grid_u(i)%y - y0)*sin(theta) + x0 - airfoil_grid_u(i)%y = -1d0*(airfoil_grid_u(i)%x - x0)*sin(theta) + (airfoil_grid_u(i)%y - y0)*cos(theta) + y0 + airfoil_grid_u(i)%y = -1._wp*(airfoil_grid_u(i)%x - x0)*sin(theta) + (airfoil_grid_u(i)%y - y0)*cos(theta) + y0 end do end if @@ -640,7 +640,7 @@ contains ! Generic loop iterators integer :: i, j, k - real(kind(0d0)) :: radius, myr, thickness + real(wp) :: radius, myr, thickness ! Transferring the circular patch's radius, centroid, smearing patch ! identity and smearing coefficient information @@ -654,7 +654,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smoothing of the circular patch's boundary is enabled. - eta = 1d0 + 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 @@ -665,8 +665,8 @@ contains myr = dsqrt((x_cc(i) - x_centroid)**2 & + (y_cc(j) - y_centroid)**2) - if (myr <= radius + thickness/2.d0 .and. & - myr >= radius - thickness/2.d0 .and. & + 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, & @@ -675,10 +675,10 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id q_prim_vf(alf_idx)%sf(i, j, 0) = patch_icpp(patch_id)%alpha(1)* & - dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) + dexp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do @@ -698,7 +698,7 @@ contains ! Generic loop iterators integer :: i, j, k - real(kind(0d0)) :: radius, myr, thickness + real(wp) :: radius, myr, thickness ! Transferring the circular patch's radius, centroid, smearing patch ! identity and smearing coefficient information @@ -714,7 +714,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smoothing of the circular patch's boundary is enabled. - eta = 1d0 + eta = 1._wp ! write for all z @@ -728,8 +728,8 @@ contains myr = dsqrt((x_cc(i) - x_centroid)**2 & + (y_cc(j) - y_centroid)**2) - if (myr <= radius + thickness/2.d0 .and. & - myr >= radius - thickness/2.d0 .and. & + 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, & @@ -738,10 +738,10 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id q_prim_vf(alf_idx)%sf(i, j, k) = patch_icpp(patch_id)%alpha(1)* & - dexp(-0.5d0*((myr - radius)**2.d0)/(thickness/3.d0)**2.d0) + dexp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do @@ -764,7 +764,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators - real(kind(0d0)) :: a, b + real(wp) :: a, b ! Transferring the elliptical patch's radii, centroid, smearing ! patch identity, and smearing coefficient information @@ -779,7 +779,7 @@ contains ! be modified as the patch is laid out on the grid, but only in ! the case that smoothing of the elliptical patch's boundary is ! enabled. - eta = 1d0 + eta = 1._wp ! Checking whether the ellipse covers a particular cell in the ! domain and verifying whether the current patch has permission @@ -792,11 +792,11 @@ contains eta = tanh(smooth_coeff/min(dx, dy)* & (sqrt(((x_cc(i) - x_centroid)/a)**2 + & ((y_cc(j) - y_centroid)/b)**2) & - - 1d0))*(-0.5d0) + 0.5d0 + - 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 <= 1d0 & + ((y_cc(j) - y_centroid)/b)**2 <= 1._wp & .and. & patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & .or. & @@ -809,7 +809,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id end if end do end do @@ -832,7 +832,7 @@ contains ! Generic loop iterators integer :: i, j, k - real(kind(0d0)) :: a, b, c + real(wp) :: a, b, c ! Transferring the ellipsoidal patch's radii, centroid, smearing ! patch identity, and smearing coefficient information @@ -849,7 +849,7 @@ contains ! be modified as the patch is laid out on the grid, but only in ! the case that smoothing of the ellipsoidal patch's boundary is ! enabled. - eta = 1d0 + eta = 1._wp ! Checking whether the ellipsoid covers a particular cell in the ! domain and verifying whether the current patch has permission @@ -871,12 +871,12 @@ contains (sqrt(((x_cc(i) - x_centroid)/a)**2 + & ((cart_y - y_centroid)/b)**2 + & ((cart_z - z_centroid)/c)**2) & - - 1d0))*(-0.5d0) + 0.5d0 + - 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 <= 1d0 & + ((cart_z - z_centroid)/c)**2 <= 1._wp & .and. & patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & .or. & @@ -889,7 +889,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id end if end do end do @@ -917,11 +917,11 @@ contains logical, intent(in) :: ib !< True if this patch is an immersed boundary integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: pi_inf, gamma, lit_gamma !< Equation of state parameters + real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the rectangle's centroid and length information if (.not. ib) then @@ -938,16 +938,16 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y + 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. - eta = 1d0 + eta = 1._wp ! Checking whether the rectangle covers a particular cell in the ! domain and verifying whether the current patch has the permission @@ -972,12 +972,12 @@ contains if ((q_prim_vf(1)%sf(i, j, 0) < 1.e-10) .and. (model_eqns == 4)) then !zero density, reassign according to Tait EOS q_prim_vf(1)%sf(i, j, 0) = & - (((q_prim_vf(E_idx)%sf(i, j, 0) + pi_inf)/(pref + pi_inf))**(1d0/lit_gamma))* & - rhoref*(1d0 - q_prim_vf(alf_idx)%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 - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id end if end if @@ -1027,7 +1027,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators - real(kind(0d0)) :: a, b, c + real(wp) :: a, b, c ! Transferring the centroid information of the line to be swept x_centroid = patch_icpp(patch_id)%x_centroid @@ -1043,7 +1043,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smoothing of the sweep line patch's boundary is enabled. - eta = 1d0 + 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 @@ -1058,7 +1058,7 @@ contains /sqrt(a**2 + b**2)) end if - if ((a*x_cc(i) + b*y_cc(j) + c >= 0d0 & + 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. & @@ -1070,7 +1070,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id end if end do @@ -1092,12 +1092,12 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: pi_inf, gamma, lit_gamma !< equation of state parameters - real(kind(0d0)) :: L0, U0 !< Taylor Green Vortex parameters + real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters + real(wp) :: L0, U0 !< Taylor Green Vortex parameters pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the patch's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1107,16 +1107,16 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y + 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. - eta = 1d0 + 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 @@ -1140,7 +1140,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id ! Assign Parameters ========================================================= q_prim_vf(mom_idx%beg)%sf(i, j, 0) = U0*sin(x_cc(i)/L0)*cos(y_cc(j)/L0) @@ -1171,13 +1171,13 @@ contains ! Generic loop iterators integer :: i, j, k ! Placeholders for the cell boundary values - real(kind(0d0)) :: a, b, c, d, pi_inf, gamma, lit_gamma + real(wp) :: a, b, c, d, pi_inf, gamma, lit_gamma @:Hardcoded1DVariables() pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the patch's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1185,14 +1185,14 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x + 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. - eta = 1d0 + eta = 1._wp ! Checking whether the line segment covers a particular cell in the ! domain and verifying whether the current patch has the permission @@ -1209,7 +1209,7 @@ contains @:Hardcoded1D() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, 0, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, 0, 0) = patch_id end if end do @@ -1231,11 +1231,11 @@ contains ! Generic loop iterators integer :: i, j, k ! Placeholders for the cell boundary values - real(kind(0d0)) :: fac, a, b, c, d, pi_inf, gamma, lit_gamma + real(wp) :: fac, a, b, c, d, pi_inf, gamma, lit_gamma pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the patch's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1243,14 +1243,14 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x + 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. - eta = 1d0 + eta = 1._wp ! Checking whether the line segment covers a particular cell in the ! domain and verifying whether the current patch has the permission @@ -1283,15 +1283,15 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: a, b, c, d !< placeholderrs for the cell boundary values - real(kind(0d0)) :: pi_inf, gamma, lit_gamma !< equation of state parameters - real(kind(0d0)) :: l, U0 !< Taylor Green Vortex parameters + real(wp) :: a, b, c, d !< placeholderrs for the cell boundary values + real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters + real(wp) :: l, U0 !< Taylor Green Vortex parameters @:Hardcoded2DVariables() pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the patch's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1301,17 +1301,17 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y + 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. - eta = 1d0 - l = 1d0 + eta = 1._wp + l = 1._wp U0 = 0.1 ! Checking whether the patch covers a particular cell in the ! domain and verifying whether the current patch has the @@ -1332,7 +1332,7 @@ contains @:Hardcoded2D() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, 0) = patch_id end if end do @@ -1352,13 +1352,13 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: pi_inf, gamma, lit_gamma !< equation of state parameters + real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters @:Hardcoded3DVariables() pi_inf = fluid_pp(1)%pi_inf gamma = fluid_pp(1)%gamma - lit_gamma = (1d0 + gamma)/gamma + lit_gamma = (1._wp + gamma)/gamma ! Transferring the patch's centroid and length information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1370,18 +1370,18 @@ contains ! Computing the beginning and the end x-, y- and z-coordinates of ! the patch based on its centroid and lengths - x_boundary%beg = x_centroid - 0.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y - z_boundary%beg = z_centroid - 0.5d0*length_z - z_boundary%end = z_centroid + 0.5d0*length_z + 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 + z_boundary%beg = z_centroid - 0.5_wp*length_z + z_boundary%end = z_centroid + 0.5_wp*length_z ! Since the analytical patch does not allow for its boundaries to get ! smoothed out, the pseudo volume fraction is set to 1 to make sure ! that only the current patch contributes to the fluid state in the ! cells that this patch covers. - eta = 1d0 + eta = 1._wp ! Checking whether the patch covers a particular cell in the domain ! and verifying whether the current patch has permission to write to @@ -1414,7 +1414,7 @@ contains @:Hardcoded3D() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id end if @@ -1436,9 +1436,9 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: radius, epsilon, beta - complex(kind(0d0)) :: cmplx_i = (0d0, 1d0) - complex(kind(0d0)) :: H + real(wp) :: radius, epsilon, beta + complex(wp) :: cmplx_i = (0._wp, 1._wp) + complex(wp) :: H ! Transferring the patch's centroid and radius information x_centroid = patch_icpp(patch_id)%x_centroid @@ -1452,7 +1452,7 @@ contains ! smoothed out, the pseudo volume fraction is set to 1 to make sure ! that only the current patch contributes to the fluid state in the ! cells that this patch covers. - eta = 1d0 + eta = 1._wp ! Checking whether the patch covers a particular cell in the domain ! and verifying whether the current patch has permission to write to @@ -1478,72 +1478,72 @@ contains call s_convert_cylindrical_to_spherical_coord(x_cc(i), y_cc(j)) - if (epsilon == 1d0) then - if (beta == 0d0) then - H = 5d-1*sqrt(3d0/pi)*cos(sph_phi) - elseif (beta == 1d0) then - H = -5d-1*sqrt(3d0/(2d0*pi))*exp(cmplx_i*z_cc(k))*sin(sph_phi) + if (epsilon == 1._wp) then + if (beta == 0._wp) then + H = 5d-1*sqrt(3._wp/pi)*cos(sph_phi) + elseif (beta == 1._wp) then + H = -5d-1*sqrt(3._wp/(2._wp*pi))*exp(cmplx_i*z_cc(k))*sin(sph_phi) end if - elseif (epsilon == 2d0) then - if (beta == 0d0) then - H = 25d-2*sqrt(5d0/pi)*(3d0*cos(sph_phi)**2 - 1d0) - elseif (beta == 1d0) then - H = -5d-1*sqrt(15d0/(2d0*pi))*exp(cmplx_i*z_cc(k))*sin(sph_phi)*cos(sph_phi) - elseif (beta == 2d0) then - H = 25d-2*sqrt(15d0/(2d0*pi))*exp(2d0*cmplx_i*z_cc(k))*sin(sph_phi)**2 + elseif (epsilon == 2._wp) then + if (beta == 0._wp) then + H = 25d-2*sqrt(5._wp/pi)*(3._wp*cos(sph_phi)**2 - 1._wp) + elseif (beta == 1._wp) then + H = -5d-1*sqrt(15._wp/(2._wp*pi))*exp(cmplx_i*z_cc(k))*sin(sph_phi)*cos(sph_phi) + elseif (beta == 2._wp) then + H = 25d-2*sqrt(15._wp/(2._wp*pi))*exp(2._wp*cmplx_i*z_cc(k))*sin(sph_phi)**2 end if - elseif (epsilon == 3d0) then - if (beta == 0d0) then - H = 25d-2*sqrt(7d0/pi)*(5d0*cos(sph_phi)**3d0 - 3d0*cos(sph_phi)) - elseif (beta == 1d0) then - H = -125d-3*sqrt(21d0/pi)*exp(cmplx_i*z_cc(k))*sin(sph_phi)* & - (5d0*cos(sph_phi)**2 - 1d0) - elseif (beta == 2d0) then - H = 25d-2*sqrt(105d0/(2d0*pi))*exp(2d0*cmplx_i*z_cc(k))* & + elseif (epsilon == 3._wp) then + if (beta == 0._wp) then + H = 25d-2*sqrt(7._wp/pi)*(5._wp*cos(sph_phi)**3._wp - 3._wp*cos(sph_phi)) + elseif (beta == 1._wp) then + H = -125d-3*sqrt(21._wp/pi)*exp(cmplx_i*z_cc(k))*sin(sph_phi)* & + (5._wp*cos(sph_phi)**2 - 1._wp) + elseif (beta == 2._wp) then + H = 25d-2*sqrt(105._wp/(2._wp*pi))*exp(2._wp*cmplx_i*z_cc(k))* & sin(sph_phi)**2*cos(sph_phi) - elseif (beta == 3d0) then - H = -125d-3*sqrt(35d0/pi)*exp(3d0*cmplx_i*z_cc(k))*sin(sph_phi)**3d0 + elseif (beta == 3._wp) then + H = -125d-3*sqrt(35._wp/pi)*exp(3._wp*cmplx_i*z_cc(k))*sin(sph_phi)**3._wp end if - elseif (epsilon == 4d0) then - if (beta == 0d0) then - H = 3d0/16d0*sqrt(1d0/pi)*(35d0*cos(sph_phi)**4d0 - & - 3d1*cos(sph_phi)**2 + 3d0) - elseif (beta == 1d0) then - H = -3d0/8d0*sqrt(5d0/pi)*exp(cmplx_i*z_cc(k))* & - sin(sph_phi)*(7d0*cos(sph_phi)**3d0 - 3d0*cos(sph_phi)) - elseif (beta == 2d0) then - H = 3d0/8d0*sqrt(5d0/(2d0*pi))*exp(2d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**2*(7d0*cos(sph_phi)**2 - 1d0) - elseif (beta == 3d0) then - H = -3d0/8d0*sqrt(35d0/pi)*exp(3d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**3d0*cos(sph_phi) - elseif (beta == 4d0) then - H = 3d0/16d0*sqrt(35d0/(2d0*pi))*exp(4d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**4d0 + elseif (epsilon == 4._wp) then + if (beta == 0._wp) then + H = 3._wp/16._wp*sqrt(1._wp/pi)*(35._wp*cos(sph_phi)**4._wp - & + 3d1*cos(sph_phi)**2 + 3._wp) + elseif (beta == 1._wp) then + H = -3._wp/8._wp*sqrt(5._wp/pi)*exp(cmplx_i*z_cc(k))* & + sin(sph_phi)*(7._wp*cos(sph_phi)**3._wp - 3._wp*cos(sph_phi)) + elseif (beta == 2._wp) then + H = 3._wp/8._wp*sqrt(5._wp/(2._wp*pi))*exp(2._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**2*(7._wp*cos(sph_phi)**2 - 1._wp) + elseif (beta == 3._wp) then + H = -3._wp/8._wp*sqrt(35._wp/pi)*exp(3._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**3._wp*cos(sph_phi) + elseif (beta == 4._wp) then + H = 3._wp/16._wp*sqrt(35._wp/(2._wp*pi))*exp(4._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**4._wp end if - elseif (epsilon == 5d0) then - if (beta == 0d0) then - H = 1d0/16d0*sqrt(11d0/pi)*(63d0*cos(sph_phi)**5d0 - & - 7d1*cos(sph_phi)**3d0 + 15d0*cos(sph_phi)) - elseif (beta == 1d0) then - H = -1d0/16d0*sqrt(165d0/(2d0*pi))*exp(cmplx_i*z_cc(k))* & - sin(sph_phi)*(21d0*cos(sph_phi)**4d0 - 14d0*cos(sph_phi)**2 + 1d0) - elseif (beta == 2d0) then - H = 125d-3*sqrt(1155d0/(2d0*pi))*exp(2d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**2*(3d0*cos(sph_phi)**3d0 - cos(sph_phi)) - elseif (beta == 3d0) then - H = -1d0/32d0*sqrt(385d0/pi)*exp(3d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**3d0*(9d0*cos(sph_phi)**2 - 1d0) - elseif (beta == 4d0) then - H = 3d0/16d0*sqrt(385d0/(2d0*pi))*exp(4d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**4d0*cos(sph_phi) - elseif (beta == 5d0) then - H = -3d0/32d0*sqrt(77d0/pi)*exp(5d0*cmplx_i*z_cc(k))* & - sin(sph_phi)**5d0 + elseif (epsilon == 5._wp) then + if (beta == 0._wp) then + H = 1._wp/16._wp*sqrt(11._wp/pi)*(63._wp*cos(sph_phi)**5._wp - & + 7d1*cos(sph_phi)**3._wp + 15._wp*cos(sph_phi)) + elseif (beta == 1._wp) then + H = -1._wp/16._wp*sqrt(165._wp/(2._wp*pi))*exp(cmplx_i*z_cc(k))* & + sin(sph_phi)*(21._wp*cos(sph_phi)**4._wp - 14._wp*cos(sph_phi)**2 + 1._wp) + elseif (beta == 2._wp) then + H = 125d-3*sqrt(1155._wp/(2._wp*pi))*exp(2._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**2*(3._wp*cos(sph_phi)**3._wp - cos(sph_phi)) + elseif (beta == 3._wp) then + H = -1._wp/32._wp*sqrt(385._wp/pi)*exp(3._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**3._wp*(9._wp*cos(sph_phi)**2 - 1._wp) + elseif (beta == 4._wp) then + H = 3._wp/16._wp*sqrt(385._wp/(2._wp*pi))*exp(4._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**4._wp*cos(sph_phi) + elseif (beta == 5._wp) then + H = -3._wp/32._wp*sqrt(77._wp/pi)*exp(5._wp*cmplx_i*z_cc(k))* & + sin(sph_phi)**5._wp end if end if - q_prim_vf(adv_idx%beg)%sf(i, j, k) = 1d0 - abs(real(H, kind(0d0))) + q_prim_vf(adv_idx%beg)%sf(i, j, k) = 1._wp - abs(real(H, wp)) end if @@ -1571,9 +1571,9 @@ contains ! Generic loop iterators integer :: i, j, k !< generic loop iterators - real(kind(0d0)) :: radius + real(wp) :: radius - real(kind(0d0)) :: radius_pressure, pressure_bubble, pressure_inf !< + real(wp) :: radius_pressure, pressure_bubble, pressure_inf !< !! Variables to initialize the pressure field that corresponds to the !! bubble-collapse test case found in Tiwari et al. (2013) @@ -1596,7 +1596,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smoothing of the spherical patch's boundary is enabled. - eta = 1d0 + 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 @@ -1619,7 +1619,7 @@ contains (sqrt((x_cc(i) - x_centroid)**2 & + (cart_y - y_centroid)**2 & + (cart_z - z_centroid)**2) & - - radius))*(-0.5d0) + 0.5d0 + - radius))*(-0.5_wp) + 0.5_wp end if @@ -1684,18 +1684,18 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y - z_boundary%beg = z_centroid - 0.5d0*length_z - z_boundary%end = z_centroid + 0.5d0*length_z + 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 + 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. - eta = 1d0 + 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 @@ -1728,7 +1728,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id end if end do @@ -1757,7 +1757,7 @@ contains logical, intent(in) :: ib !< True if this patch is an immersed boundary integer :: i, j, k !< Generic loop iterators - real(kind(0d0)) :: radius + real(wp) :: radius ! Transferring the cylindrical patch's centroid, length, radius, ! smoothing patch identity and smoothing coefficient information @@ -1784,17 +1784,17 @@ contains ! 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.5d0*length_x - x_boundary%end = x_centroid + 0.5d0*length_x - y_boundary%beg = y_centroid - 0.5d0*length_y - y_boundary%end = y_centroid + 0.5d0*length_y - z_boundary%beg = z_centroid - 0.5d0*length_z - z_boundary%end = z_centroid + 0.5d0*length_z + 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 + 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. - eta = 1d0 + eta = 1._wp ! Checking whether the cylinder covers a particular cell in the ! domain and verifying whether the current patch has the permission @@ -1817,17 +1817,17 @@ contains eta = tanh(smooth_coeff/min(dy, dz)* & (sqrt((cart_y - y_centroid)**2 & + (cart_z - z_centroid)**2) & - - radius))*(-0.5d0) + 0.5d0 + - 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.5d0) + 0.5d0 + - 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.5d0) + 0.5d0 + - radius))*(-0.5_wp) + 0.5_wp end if end if @@ -1862,7 +1862,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id end if end if @@ -1912,7 +1912,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators - real(kind(0d0)) :: a, b, c, d + real(wp) :: a, b, c, d ! Transferring the centroid information of the plane to be swept x_centroid = patch_icpp(patch_id)%x_centroid @@ -1930,7 +1930,7 @@ contains ! Initializing the pseudo volume fraction value to 1. The value will ! be modified as the patch is laid out on the grid, but only in the ! case that smearing of the sweep plane patch's boundary is enabled. - eta = 1d0 + 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 @@ -1955,7 +1955,7 @@ contains /sqrt(a**2 + b**2 + c**2)) end if - if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0d0 & + 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. & @@ -1968,7 +1968,7 @@ contains @:analytical() ! Updating the patch identities bookkeeping variable - if (1d0 - eta < 1d-16) patch_id_fp(i, j, k) = patch_id + if (1._wp - eta < 1d-16) patch_id_fp(i, j, k) = patch_id end if end do @@ -1995,7 +1995,7 @@ contains t_vec3 :: point - real(kind(0d0)) :: grid_mm(1:3, 1:2) + real(wp) :: grid_mm(1:3, 1:2) integer :: cell_num integer :: ncells @@ -2017,7 +2017,7 @@ contains if (proc_rank == 0) then write (*, "(A, 3(2X, F20.10))") " > Model: Min:", bbox%min(1:3) - write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2d0 + 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) @@ -2029,11 +2029,11 @@ contains if (p > 0) then grid_mm(3, :) = (/minval(z_cc) - 0d5*dz, maxval(z_cc) + 0d5*dz/) else - grid_mm(3, :) = (/0d0, 0d0/) + 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))/2d0 + 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 @@ -2047,7 +2047,7 @@ contains nint(100*real(cell_num)/ncells), "%" end if - point = (/x_cc(i), y_cc(j), 0d0/) + point = (/x_cc(i), y_cc(j), 0._wp/) if (p > 0) then point(3) = z_cc(k) end if @@ -2060,13 +2060,13 @@ contains if (patch_icpp(patch_id)%smoothen) then if (eta > patch_icpp(patch_id)%model%threshold) then - eta = 1d0 + eta = 1._wp end if else if (eta > patch_icpp(patch_id)%model%threshold) then - eta = 1d0 + eta = 1._wp else - eta = 0d0 + eta = 0._wp end if end if @@ -2091,7 +2091,7 @@ contains subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) !$acc routine seq - real(kind(0d0)), intent(in) :: cyl_y, cyl_z + real(wp), intent(in) :: cyl_y, cyl_z cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) @@ -2114,7 +2114,7 @@ contains subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) !$acc routine seq - real(kind(0d0)), intent(IN) :: cyl_x, cyl_y + real(wp), intent(IN) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) @@ -2126,13 +2126,13 @@ contains !! @param a Starting position function f_r(myth, offset, a) !$acc routine seq - real(kind(0d0)), intent(in) :: myth, offset, a - real(kind(0d0)) :: b - real(kind(0d0)) :: f_r + real(wp), intent(in) :: myth, offset, a + real(wp) :: b + real(wp) :: f_r !r(th) = a + b*th - b = 2.d0*a/(2.d0*pi) + b = 2._wp*a/(2._wp*pi) f_r = a + b*myth + offset end function f_r diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 0247043dcf..0ef4e2a0cb 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -54,9 +54,9 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer :: i, j, k, l !< generic loop operators - real(kind(0d0)) :: perturb_alpha - real(kind(0d0)) :: alpha_unadv - real(kind(0d0)) :: rand_real + real(wp) :: perturb_alpha + real(wp) :: alpha_unadv + real(wp) :: rand_real call random_seed() do k = 0, p @@ -68,7 +68,7 @@ contains ! Perturb partial density fields to match perturbed volume fraction fields ! IF ((perturb_alpha >= 25d-2) .AND. (perturb_alpha <= 75d-2)) THEN - if ((perturb_alpha /= 0d0) .and. (perturb_alpha /= 1d0)) then + if ((perturb_alpha /= 0._wp) .and. (perturb_alpha /= 1._wp)) then ! Derive new partial densities do l = 1, num_fluids @@ -86,8 +86,8 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer :: i, j, k, l !< generic loop iterators - real(kind(0d0)) :: perturb_alpha - real(kind(0d0)) :: 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 @@ -97,10 +97,10 @@ contains perturb_alpha = q_prim_vf(E_idx + perturb_flow_fluid)%sf(i, j, k) call random_number(rand_real) rand_real = rand_real*perturb_flow_mag - q_prim_vf(mom_idx%beg)%sf(i, j, k) = (1.d0 + rand_real)*q_prim_vf(mom_idx%beg)%sf(i, j, k) + q_prim_vf(mom_idx%beg)%sf(i, j, k) = (1._wp + rand_real)*q_prim_vf(mom_idx%beg)%sf(i, j, k) q_prim_vf(mom_idx%end)%sf(i, j, k) = rand_real*q_prim_vf(mom_idx%beg)%sf(i, j, k) if (bubbles) then - q_prim_vf(alf_idx)%sf(i, j, k) = (1.d0 + rand_real)*q_prim_vf(alf_idx)%sf(i, j, k) + q_prim_vf(alf_idx)%sf(i, j, k) = (1._wp + rand_real)*q_prim_vf(alf_idx)%sf(i, j, k) end if end do end do @@ -116,39 +116,39 @@ contains !! (2,2), (2,-2), (1,1), (1,-1) areadded on top of 2D waves. subroutine s_superposition_instability_wave(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(mixlayer_nvar, 0:m, 0:n, 0:p) :: wave, wave1, wave2, wave_tmp - real(kind(0d0)) :: uratio, Ldomain + real(wp), dimension(mixlayer_nvar, 0:m, 0:n, 0:p) :: wave, wave1, wave2, wave_tmp + real(wp) :: uratio, Ldomain integer :: i, j, k, q - uratio = 1d0/patch_icpp(1)%vel(1) + uratio = 1._wp/patch_icpp(1)%vel(1) Ldomain = mixlayer_domain*patch_icpp(1)%length_y - wave = 0d0 - wave1 = 0d0 - wave2 = 0d0 + wave = 0._wp + wave1 = 0._wp + wave2 = 0._wp ! Compute 2D waves - call s_instability_wave(2*pi*4.0/Ldomain, 0d0, wave_tmp, 0d0) + call s_instability_wave(2*pi*4.0/Ldomain, 0._wp, wave_tmp, 0._wp) wave1 = wave1 + wave_tmp - call s_instability_wave(2*pi*2.0/Ldomain, 0d0, wave_tmp, 0d0) + call s_instability_wave(2*pi*2.0/Ldomain, 0._wp, wave_tmp, 0._wp) wave1 = wave1 + wave_tmp - call s_instability_wave(2*pi*1.0/Ldomain, 0d0, wave_tmp, 0d0) + call s_instability_wave(2*pi*1.0/Ldomain, 0._wp, wave_tmp, 0._wp) wave1 = wave1 + wave_tmp wave = wave1*0.05 if (p > 0) then ! Compute 3D waves with phase shifts. - call s_instability_wave(2*pi*4.0/Ldomain, 2*pi*4.0/Ldomain, wave_tmp, 2*pi*11d0/31d0) + call s_instability_wave(2*pi*4.0/Ldomain, 2*pi*4.0/Ldomain, wave_tmp, 2*pi*11._wp/31._wp) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*2.0/Ldomain, 2*pi*2.0/Ldomain, wave_tmp, 2*pi*13d0/31d0) + call s_instability_wave(2*pi*2.0/Ldomain, 2*pi*2.0/Ldomain, wave_tmp, 2*pi*13._wp/31._wp) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*1.0/Ldomain, 2*pi*1.0/Ldomain, wave_tmp, 2*pi*17d0/31d0) + call s_instability_wave(2*pi*1.0/Ldomain, 2*pi*1.0/Ldomain, wave_tmp, 2*pi*17._wp/31._wp) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*4.0/Ldomain, -2*pi*4.0/Ldomain, wave_tmp, 2*pi*19d0/31d0) + call s_instability_wave(2*pi*4.0/Ldomain, -2*pi*4.0/Ldomain, wave_tmp, 2*pi*19._wp/31._wp) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*2.0/Ldomain, -2*pi*2.0/Ldomain, wave_tmp, 2*pi*23d0/31d0) + call s_instability_wave(2*pi*2.0/Ldomain, -2*pi*2.0/Ldomain, wave_tmp, 2*pi*23._wp/31._wp) wave2 = wave2 + wave_tmp - call s_instability_wave(2*pi*1.0/Ldomain, -2*pi*1.0/Ldomain, wave_tmp, 2*pi*29d0/31d0) + call s_instability_wave(2*pi*1.0/Ldomain, -2*pi*1.0/Ldomain, wave_tmp, 2*pi*29._wp/31._wp) wave2 = wave2 + wave_tmp wave = wave + 0.15*wave2 end if @@ -178,20 +178,20 @@ contains !> This subroutine computes equilibrium bubble radius of the perturbed pressure field subroutine s_compute_equilibrium_state(fP, fR0, fR) - real(kind(0d0)), intent(in) :: fP, fR0 - real(kind(0d0)), intent(inout) :: fR - real(kind(0d0)) :: f0, f1 - real(kind(0d0)) :: gam_b + real(wp), intent(in) :: fP, fR0 + real(wp), intent(inout) :: fR + real(wp) :: f0, f1 + real(wp) :: gam_b integer :: ii, jj - gam_b = 1d0 + 1d0/fluid_pp(num_fluids + 1)%gamma + gam_b = 1._wp + 1._wp/fluid_pp(num_fluids + 1)%gamma ! Loop ii = 1 do while (.true.) - f0 = (Ca + 2d0/Web)*(fR0/fR)**(3d0*gam_b) - 2d0/(Web*fR) + 1d0 - Ca - fP - f1 = -3d0*gam_b*(Ca + 2d0/Web)*(fR0/fR)**(3d0*gam_b + 1d0) + 2d0/(Web*fR**2d0) + f0 = (Ca + 2._wp/Web)*(fR0/fR)**(3._wp*gam_b) - 2._wp/(Web*fR) + 1._wp - Ca - fP + f1 = -3._wp*gam_b*(Ca + 2._wp/Web)*(fR0/fR)**(3._wp*gam_b + 1._wp) + 2._wp/(Web*fR**2._wp) if (abs(f0) <= 1e-10) then ! Converged @@ -205,7 +205,7 @@ contains if (ieee_is_nan(f0) .or. & ieee_is_nan(f1) .or. & ii > 1000 .or. & - fR < 0d0) then + fR < 0._wp) then print *, "Failed to compute equilibrium radius" @@ -224,31 +224,31 @@ contains !! Euler equations with parallel mean flow assumption !! (See Sandham 1989 PhD thesis for details). subroutine s_instability_wave(alpha, beta, wave, shift) - real(kind(0d0)), intent(in) :: alpha, beta !< spatial wavenumbers - real(kind(0d0)), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave !< instability wave - real(kind(0d0)) :: shift !< phase shift - real(kind(0d0)), dimension(0:nbp - 1) :: u_mean !< mean density and velocity profiles - real(kind(0d0)) :: rho_mean, p_mean !< mean density and pressure - real(kind(0d0)), dimension(0:nbp - 1, 0:nbp - 1) :: d !< differential operator in y dir - real(kind(0d0)) :: gam, pi_inf, mach, c1, adv - real(kind(0d0)) :: xratio, uratio + real(wp), intent(in) :: alpha, beta !< spatial wavenumbers + real(wp), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave !< instability wave + real(wp) :: shift !< phase shift + real(wp), dimension(0:nbp - 1) :: u_mean !< mean density and velocity profiles + real(wp) :: rho_mean, p_mean !< mean density and pressure + real(wp), dimension(0:nbp - 1, 0:nbp - 1) :: d !< differential operator in y dir + real(wp) :: gam, pi_inf, mach, c1, adv + real(wp) :: xratio, uratio integer :: i, j !< generic loop iterators xratio = mixlayer_vel_coef - uratio = 1d0/patch_icpp(1)%vel(1) + uratio = 1._wp/patch_icpp(1)%vel(1) ! Set fluid flow properties if (bubbles) then adv = patch_icpp(1)%alpha(num_fluids) else - adv = 0d0 + adv = 0._wp end if - gam = 1d0 + 1d0/fluid_pp(1)%gamma - pi_inf = fluid_pp(1)%pi_inf*(gam - 1d0)/gam*uratio**2 + gam = 1._wp + 1._wp/fluid_pp(1)%gamma + pi_inf = fluid_pp(1)%pi_inf*(gam - 1._wp)/gam*uratio**2 rho_mean = patch_icpp(1)%alpha_rho(1) p_mean = patch_icpp(1)%pres*uratio**2 - c1 = sqrt((gam*(p_mean + pi_inf))/(rho_mean*(1d0 - adv))) - mach = 1d0/c1 + c1 = sqrt((gam*(p_mean + pi_inf))/(rho_mean*(1._wp - adv))) + mach = 1._wp/c1 ! Assign mean profiles do j = 0, n + 1 @@ -257,15 +257,15 @@ contains ! Compute differential operator in y-dir ! based on 2nd order central difference - d = 0d0 - d(0, 0) = -1d0/((y_cb(0) - y_cb(-1))*xratio) - d(0, 1) = 1d0/((y_cb(0) - y_cb(-1))*xratio) + d = 0._wp + d(0, 0) = -1._wp/((y_cb(0) - y_cb(-1))*xratio) + d(0, 1) = 1._wp/((y_cb(0) - y_cb(-1))*xratio) do j = 1, n - d(j, j - 1) = -1d0/((y_cb(j) - y_cb(j - 2))*xratio) - d(j, j + 1) = 1d0/((y_cb(j) - y_cb(j - 2))*xratio) + d(j, j - 1) = -1._wp/((y_cb(j) - y_cb(j - 2))*xratio) + d(j, j + 1) = 1._wp/((y_cb(j) - y_cb(j - 2))*xratio) end do - d(n + 1, n) = -1d0/((y_cb(n) - y_cb(n - 1))*xratio) - d(n + 1, n + 1) = 1d0/((y_cb(n) - y_cb(n - 1))*xratio) + d(n + 1, n) = -1._wp/((y_cb(n) - y_cb(n - 1))*xratio) + d(n + 1, n + 1) = 1._wp/((y_cb(n) - y_cb(n - 1))*xratio) ! Compute call s_solve_linear_system(alpha, beta, u_mean, rho_mean, p_mean, d, gam, pi_inf, mach, wave, shift) @@ -276,21 +276,21 @@ contains !! generate instability waves for the given set of spatial !! wave numbers and phase shift. subroutine s_solve_linear_system(alpha, beta, u_mean, rho_mean, p_mean, d, gam, pi_inf, mach, wave, shift) - real(kind(0d0)), intent(in) :: alpha, beta !< spatial wavenumbers - real(kind(0d0)), dimension(0:nbp - 1), intent(in) :: u_mean !< mean velocity profiles - real(kind(0d0)), intent(in) :: rho_mean, p_mean !< mean density and pressure - real(kind(0d0)), dimension(0:nbp - 1, 0:nbp - 1), intent(in) :: d !< differential operator in y dir - real(kind(0d0)), intent(in) :: gam, pi_inf, mach, shift - real(kind(0d0)), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave - - real(kind(0d0)), dimension(0:nbp - 1) :: drho_mean, du_mean !< y-derivatives of mean profiles - real(kind(0d0)), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1) :: ar, ai !< matrices for eigenvalue problem - real(kind(0d0)), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1) :: br, bi, ci !< matrices for eigenvalue problem - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1) :: hr, hi !< matrices for eigenvalue problem - - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1) :: zr, zi !< eigenvectors - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: wr, wi !< eigenvalues - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: fv1, fv2, fv3 !< temporary memory + real(wp), intent(in) :: alpha, beta !< spatial wavenumbers + real(wp), dimension(0:nbp - 1), intent(in) :: u_mean !< mean velocity profiles + real(wp), intent(in) :: rho_mean, p_mean !< mean density and pressure + real(wp), dimension(0:nbp - 1, 0:nbp - 1), intent(in) :: d !< differential operator in y dir + real(wp), intent(in) :: gam, pi_inf, mach, shift + real(wp), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave + + real(wp), dimension(0:nbp - 1) :: drho_mean, du_mean !< y-derivatives of mean profiles + real(wp), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1) :: ar, ai !< matrices for eigenvalue problem + real(wp), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1) :: br, bi, ci !< matrices for eigenvalue problem + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1) :: hr, hi !< matrices for eigenvalue problem + + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1) :: zr, zi !< eigenvectors + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: wr, wi !< eigenvalues + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: fv1, fv2, fv3 !< temporary memory integer :: ierr integer :: i, j, k, l !< generic loop iterators @@ -301,7 +301,7 @@ contains drho_mean(j) = 0 du_mean(j) = 0 do k = 0, nbp - 1 - drho_mean(j) = 0d0 + drho_mean(j) = 0._wp du_mean(j) = du_mean(j) + d(j, k)*u_mean(k) end do end do @@ -310,9 +310,9 @@ contains ! systems of equation (i.e. we are going to solve x for Ax = lambda x). ! Here, B includes components of A without differential operator, and ! C includes components of A with differential operator. - br = 0d0 - bi = 0d0 - ci = 0d0 + br = 0._wp + bi = 0._wp + ci = 0._wp do j = 0, nbp - 1 ii = mixlayer_var(1); jj = mixlayer_var(1); br((ii - 1)*nbp + j, (jj - 1)*nbp + j) = alpha*u_mean(j); ii = mixlayer_var(1); jj = mixlayer_var(2); br((ii - 1)*nbp + j, (jj - 1)*nbp + j) = alpha*rho_mean; @@ -353,12 +353,12 @@ contains !> This subroutine applies non-reflecting subsonic buffer boundary condition !! to the linear system of equations (i.e. matrix A). subroutine s_instability_nonreflecting_subsonic_buffer_bc(ar, ai, hr, hi, rho_mean, mach) - real(kind(0d0)), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1), intent(inout) :: ar, ai !< matrices for eigenvalue problem - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1), intent(out) :: hr, hi !< matrices for eigenvalue problem - real(kind(0d0)), intent(in) :: rho_mean !< mean density profiles - real(kind(0d0)), intent(in) :: mach - real(kind(0d0)), dimension(0:mixlayer_nvar*n - 1, 0:mixlayer_nvar*n - 1) :: fr, fi !< matrices for eigenvalue problem - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - 1) :: gr, gi !< matrices for eigenvalue problem + real(wp), dimension(0:mixlayer_nvar*nbp - 1, 0:mixlayer_nvar*nbp - 1), intent(inout) :: ar, ai !< matrices for eigenvalue problem + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1), intent(out) :: hr, hi !< matrices for eigenvalue problem + real(wp), intent(in) :: rho_mean !< mean density profiles + real(wp), intent(in) :: mach + real(wp), dimension(0:mixlayer_nvar*n - 1, 0:mixlayer_nvar*n - 1) :: fr, fi !< matrices for eigenvalue problem + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - 1) :: gr, gi !< matrices for eigenvalue problem integer :: i, j, k, l, ii, jj ! Condition 1: v = 0 at BC - no action required here @@ -424,8 +424,8 @@ contains end do ! Remove unnecessary rows of the matrix A (rho, u, v, w, p at the boundaries) - fr = 0d0 - fi = 0d0 + fr = 0._wp + fi = 0._wp do ii = 1, mixlayer_nvar do jj = 1, mixlayer_nvar do k = 0, n - 1 @@ -437,8 +437,8 @@ contains end do end do - gr = 0d0 - gi = 0d0 + gr = 0._wp + gi = 0._wp do ii = 1, mixlayer_nvar do j = 0, mixlayer_nvar*n - 1 if (ii <= mixlayer_var(2)) then @@ -460,8 +460,8 @@ contains end do end do - hr = 0d0 - hi = 0d0 + hr = 0._wp + hi = 0._wp do i = 0, mixlayer_nvar*n - n_bc_skip - 1 do jj = 1, mixlayer_nvar if (jj <= mixlayer_var(2)) then @@ -489,17 +489,17 @@ contains !! eigenvalue and corresponding eigenvector among the !! given set of eigenvalues and eigenvectors. subroutine s_generate_wave(wr, wi, zr, zi, rho_mean, mach, alpha, beta, wave, shift) - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1), intent(in) :: wr, wi !< eigenvalues - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1), intent(in) :: zr, zi !< eigenvectors - real(kind(0d0)), intent(in) :: rho_mean - real(kind(0d0)), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave - real(kind(0d0)), intent(in) :: alpha, beta, mach, shift - real(kind(0d0)), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: vr, vi, vnr, vni !< most unstable eigenvector - real(kind(0d0)), dimension(0:mixlayer_nvar*nbp - 1) :: xbr, xbi !< eigenvectors - real(kind(0d0)), dimension(0:mixlayer_nvar*(nbp - 1) - 1) :: xcr, xci !< eigenvectors - real(kind(0d0)) :: ang, norm - real(kind(0d0)) :: tr, ti, cr, ci !< temporary memory - real(kind(0d0)) :: xratio + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1), intent(in) :: wr, wi !< eigenvalues + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1, 0:mixlayer_nvar*n - n_bc_skip - 1), intent(in) :: zr, zi !< eigenvectors + real(wp), intent(in) :: rho_mean + real(wp), dimension(mixlayer_nvar, 0:m, 0:n, 0:p), intent(inout) :: wave + real(wp), intent(in) :: alpha, beta, mach, shift + real(wp), dimension(0:mixlayer_nvar*n - n_bc_skip - 1) :: vr, vi, vnr, vni !< most unstable eigenvector + real(wp), dimension(0:mixlayer_nvar*nbp - 1) :: xbr, xbi !< eigenvectors + real(wp), dimension(0:mixlayer_nvar*(nbp - 1) - 1) :: xcr, xci !< eigenvectors + real(wp) :: ang, norm + real(wp) :: tr, ti, cr, ci !< temporary memory + real(wp) :: xratio integer idx integer i, j, k @@ -516,7 +516,7 @@ contains vi = zi(:, k) ! Normalize the eigenvector by its component with the largest modulus. - norm = 0d0 + norm = 0._wp do i = 0, mixlayer_nvar*n - n_bc_skip - 1 if (dsqrt(vr(i)**2 + vi(i)**2) > norm) then idx = i @@ -533,8 +533,8 @@ contains end do ! Reassign missing values at boundaries based on the boundary condition - xbr = 0d0 - xbi = 0d0 + xbr = 0._wp + xbi = 0._wp do i = 1, mixlayer_nvar if (i <= mixlayer_var(2)) then do k = 0, n - 1 @@ -579,8 +579,8 @@ contains xbi(mixlayer_var(4)*nbp + nbp - 1) = xbi(mixlayer_var(4)*nbp + n) - xbi(mixlayer_var(2)*nbp + n)*rho_mean/mach ! Compute average to get cell-centered values - xcr = 0d0 - xci = 0d0 + xcr = 0._wp + xci = 0._wp do i = 1, mixlayer_nvar do k = 0, n xcr((i - 1)*(nbp - 1) + k) = 5d-1*(xbr((i - 1)*nbp + k) + xbr((i - 1)*nbp + k + 1)) diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 7712db0a0f..8f3580c323 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -262,7 +262,7 @@ contains end if ! Computing cell-center locations - x_cc(0:m) = (x_cb(0:m) + x_cb(-1:(m - 1)))/2d0 + 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)) @@ -294,7 +294,7 @@ contains end if ! Computing cell-center locations - y_cc(0:n) = (y_cb(0:n) + y_cb(-1:(n - 1)))/2d0 + 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)) @@ -326,7 +326,7 @@ contains end if ! Computing cell-center locations - z_cc(0:p) = (z_cb(0:p) + z_cb(-1:(p - 1)))/2d0 + 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)) @@ -363,7 +363,7 @@ contains ! Cell-boundary Data Consistency Check in x-direction ============== - if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0d0)) then + if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0._wp)) then call s_mpi_abort('x_cb.dat in '//trim(t_step_dir)// & ' contains non-positive cell-spacings. Exiting ...') end if @@ -374,7 +374,7 @@ contains if (n > 0) then - if (any(y_cb(0:n) - y_cb(-1:n - 1) <= 0d0)) 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 ...') @@ -386,7 +386,7 @@ contains if (p > 0) then - if (any(z_cb(0:p) - z_cb(-1:p - 1) <= 0d0)) 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 ...') @@ -419,7 +419,7 @@ contains ! Generic string used to store the address of a particular file character(LEN= & - int(floor(log10(real(sys_size, kind(0d0))))) + 1) :: file_num !< + 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 @@ -543,7 +543,7 @@ contains #ifdef MFC_MPI - real(kind(0d0)), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status @@ -562,7 +562,7 @@ contains if (file_exist) then data_size = m_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ_ALL(ifile, x_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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... ') @@ -571,7 +571,7 @@ contains ! 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)))/2d0 + 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) @@ -587,7 +587,7 @@ contains if (file_exist) then data_size = n_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ_ALL(ifile, y_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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... ') @@ -596,7 +596,7 @@ contains ! 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)))/2d0 + 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) @@ -612,7 +612,7 @@ contains if (file_exist) then data_size = p_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ_ALL(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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... ') @@ -621,7 +621,7 @@ contains ! 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)))/2d0 + 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) @@ -694,8 +694,8 @@ contains 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -706,10 +706,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do if (qbmm .and. .not. polytropic) then @@ -719,10 +719,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -777,9 +777,9 @@ contains end if !Initialize pb based on surface tension for qbmm (polytropic) if (qbmm .and. polytropic .and. (.not. f_is_default(Web))) then - pb0 = pref + 2d0*fluid_pp(1)%ss/(R0*R0ref) + pb0 = pref + 2._wp*fluid_pp(1)%ss/(R0*R0ref) pb0 = pb0/pref - pref = 1d0 + pref = 1._wp end if call s_initialize_data_output_module() call s_initialize_variables_conversion_module() @@ -828,9 +828,9 @@ contains subroutine s_apply_initial_condition(start, finish, proc_time, time_avg, time_final, file_exists) - real(kind(0d0)), intent(inout) :: start, finish - real(kind(0d0)), dimension(:), intent(inout) :: proc_time - real(kind(0d0)), intent(inout) :: time_avg, time_final + real(wp), intent(inout) :: start, finish + real(wp), dimension(:), intent(inout) :: proc_time + real(wp), intent(inout) :: time_avg, time_final logical, intent(inout) :: file_exists ! Setting up the grid and the initial condition. If the grid is read in from @@ -865,8 +865,8 @@ contains subroutine s_save_data(proc_time, time_avg, time_final, file_exists) - real(kind(0d0)), dimension(:), intent(inout) :: proc_time - real(kind(0d0)), intent(inout) :: time_avg, time_final + real(wp), dimension(:), intent(inout) :: proc_time + real(wp), intent(inout) :: time_avg, time_final logical, intent(inout) :: file_exists call s_mpi_barrier() @@ -876,7 +876,7 @@ contains end if if (proc_rank == 0) then - time_final = 0d0 + time_final = 0._wp if (num_procs == 1) then time_final = time_avg print *, "Elapsed Time", time_final diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 544c0311a7..0bda585c0c 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -18,8 +18,8 @@ program p_main integer :: i logical :: file_exists - real(kind(0d0)) :: start, finish, time_avg, time_final - real(kind(0d0)), allocatable, dimension(:) :: proc_time + real(wp) :: start, finish, time_avg, time_final + real(wp), allocatable, dimension(:) :: proc_time call random_seed() diff --git a/src/simulation/include/inline_riemann.fpp b/src/simulation/include/inline_riemann.fpp index 761ab07636..cbceb1f21b 100644 --- a/src/simulation/include/inline_riemann.fpp +++ b/src/simulation/include/inline_riemann.fpp @@ -1,9 +1,9 @@ #:def arithmetic_avg() rho_avg = 5d-1*(rho_L + rho_R) - vel_avg_rms = 0d0 + vel_avg_rms = 0._wp !$acc loop seq do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 + vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2._wp end do H_avg = 5d-1*(H_L + H_R) @@ -13,11 +13,11 @@ #:def roe_avg() rho_avg = sqrt(rho_L*rho_R) - vel_avg_rms = 0d0 + vel_avg_rms = 0._wp !$acc loop seq do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & - (sqrt(rho_L) + sqrt(rho_R))**2d0 + 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)/ & @@ -27,8 +27,8 @@ (sqrt(rho_L) + sqrt(rho_R)) rho_avg = sqrt(rho_L*rho_R) - vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2d0/ & - (sqrt(rho_L) + sqrt(rho_R))**2d0 + 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 #:enddef roe_avg @@ -46,14 +46,14 @@ #:def compute_low_Mach_correction() - zcoef = min(1d0, max(vel_L_rms**5d-1/c_L, vel_R_rms**5d-1/c_R)) - pcorr = 0d0 + zcoef = min(1._wp, max(vel_L_rms**5d-1/c_L, vel_R_rms**5d-1/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 - 1d0) + (zcoef - 1._wp) else if (low_Mach == 2) then vel_L_tmp = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) vel_R_tmp = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_R(dir_idx(1)) - vel_L(dir_idx(1)))) diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 02ee735091..dfe2f8a163 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -30,25 +30,25 @@ module m_acoustic_src @:CRAY_DECLARE_GLOBAL(logical, dimension(:), dipole) !$acc declare link(dipole) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), loc_acoustic) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), loc_acoustic) !$acc declare link(loc_acoustic) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay) !$acc declare link(mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), foc_length, aperture) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), foc_length, aperture) !$acc declare link(foc_length, aperture) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), element_spacing_angle, element_polygon_ratio, rotate_angle) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), element_spacing_angle, element_polygon_ratio, rotate_angle) !$acc declare link(element_spacing_angle, element_polygon_ratio, rotate_angle) @:CRAY_DECLARE_GLOBAL(integer, dimension(:), num_elements, element_on) !$acc declare link(num_elements, element_on) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), mass_src, e_src) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), mass_src, e_src) !$acc declare link(mass_src, e_src) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), mom_src) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), mom_src) !$acc declare link(mom_src) @:CRAY_DECLARE_GLOBAL(integer, dimension(:), source_spatials_num_points) @@ -64,16 +64,16 @@ module m_acoustic_src logical, allocatable, dimension(:) :: dipole !$acc declare create(dipole) - real(kind(0d0)), allocatable, target, dimension(:, :) :: loc_acoustic + real(wp), allocatable, target, dimension(:, :) :: loc_acoustic !$acc declare create(loc_acoustic) - real(kind(0d0)), allocatable, dimension(:) :: mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay + real(wp), allocatable, dimension(:) :: mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay !$acc declare create(mag, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay) - real(kind(0d0)), allocatable, dimension(:) :: foc_length, aperture + real(wp), allocatable, dimension(:) :: foc_length, aperture !$acc declare create(foc_length, aperture) - real(kind(0d0)), allocatable, dimension(:) :: element_spacing_angle, element_polygon_ratio, rotate_angle + real(wp), allocatable, dimension(:) :: element_spacing_angle, element_polygon_ratio, rotate_angle !$acc declare create(element_spacing_angle, element_polygon_ratio, rotate_angle) integer, allocatable, dimension(:) :: num_elements, element_on @@ -81,8 +81,8 @@ module m_acoustic_src !> @name Acoustic source terms !> @{ - real(kind(0d0)), allocatable, dimension(:, :, :) :: mass_src, e_src - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_src + real(wp), allocatable, dimension(:, :, :) :: mass_src, e_src + real(wp), allocatable, dimension(:, :, :, :) :: mom_src !> @} !$acc declare create(mass_src, e_src, mom_src) @@ -128,12 +128,12 @@ contains element_on(i) = acoustic(i)%element_on end if if (f_is_default(acoustic(i)%rotate_angle)) then - rotate_angle(i) = 0d0 + rotate_angle(i) = 0._wp 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) = 0d0 ! Defaults to zero for sine and square waves + delay(i) = 0._wp ! Defaults to zero for sine and square waves else delay(i) = acoustic(i)%delay end if @@ -167,12 +167,12 @@ contains integer, intent(in) :: t_step - real(kind(0d0)) :: myalpha(num_fluids), myalpha_rho(num_fluids) - real(kind(0d0)) :: myRho, B_tait - real(kind(0d0)) :: sim_time, c, small_gamma - real(kind(0d0)) :: frequency_local, gauss_sigma_time_local - real(kind(0d0)) :: mass_src_diff, mom_src_diff - real(kind(0d0)) :: source_temporal + real(wp) :: myalpha(num_fluids), myalpha_rho(num_fluids) + 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 integer :: i, j, k, l, q !< generic loop variables integer :: ai !< acoustic source index @@ -188,11 +188,11 @@ contains do l = 0, p do k = 0, n do j = 0, m - mass_src(j, k, l) = 0d0 - mom_src(1, j, k, l) = 0d0 - e_src(j, k, l) = 0d0 - if (n > 0) mom_src(2, j, k, l) = 0d0 - if (p > 0) mom_src(3, j, k, l) = 0d0 + mass_src(j, k, l) = 0._wp + mom_src(1, j, k, l) = 0._wp + e_src(j, k, l) = 0._wp + if (n > 0) mom_src(2, j, k, l) = 0._wp + if (p > 0) mom_src(3, j, k, l) = 0._wp end do end do end do @@ -215,9 +215,9 @@ contains l = source_spatials(ai)%coord(3, i) ! Compute speed of sound - myRho = 0d0 - B_tait = 0d0 - small_gamma = 0d0 + myRho = 0._wp + B_tait = 0._wp + small_gamma = 0._wp !$acc loop do q = 1, num_fluids @@ -249,8 +249,8 @@ contains end do end if - small_gamma = 1d0/small_gamma + 1d0 - c = dsqrt(small_gamma*(q_prim_vf(E_idx)%sf(j, k, l) + ((small_gamma - 1d0)/small_gamma)*B_tait)/myRho) + small_gamma = 1._wp/small_gamma + 1._wp + c = dsqrt(small_gamma*(q_prim_vf(E_idx)%sf(j, k, l) + ((small_gamma - 1._wp)/small_gamma)*B_tait)/myRho) ! Wavelength to frequency conversion if (pulse(ai) == 1 .or. pulse(ai) == 3) frequency_local = f_frequency_local(freq_conv_flag, ai, c) @@ -261,13 +261,13 @@ contains mom_src_diff = source_temporal*source_spatials(ai)%val(i) if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) - mass_src(j, k, l) = mass_src(j, k, l) + 2d0*mom_src_diff/c - if (model_eqns /= 4) E_src(j, k, l) = E_src(j, k, l) + 2d0*mom_src_diff*c/(small_gamma - 1d0) + 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(1d0, dir(ai)) ! Left or right-going wave + 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 @@ -301,7 +301,7 @@ contains ! Update energy source term if (model_eqns /= 4) then - E_src(j, k, l) = E_src(j, k, l) + mass_src_diff*c**2d0/(small_gamma - 1d0) + E_src(j, k, l) = E_src(j, k, l) + mass_src_diff*c**2._wp/(small_gamma - 1._wp) end if end do @@ -337,51 +337,51 @@ contains subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source) !$acc routine seq integer, intent(in) :: ai, term_index - real(kind(0d0)), intent(in) :: sim_time, c - real(kind(0d0)), intent(in) :: frequency_local, gauss_sigma_time_local - real(kind(0d0)), intent(out) :: source + real(wp), intent(in) :: sim_time, c + real(wp), intent(in) :: frequency_local, gauss_sigma_time_local + real(wp), intent(out) :: source - real(kind(0d0)) :: omega ! angular frequency - real(kind(0d0)) :: sine_wave ! sine function for square wave - real(kind(0d0)) :: 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 = 1d0 + 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.85d0); ! Empirical correction + foc_length_factor = foc_length(ai)**(-0.85_wp); ! Empirical correction else foc_length_factor = 1/foc_length(ai); end if - source = 0d0 + source = 0._wp if (pulse(ai) == 1) then ! Sine wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return - omega = 2d0*pi*frequency_local + omega = 2._wp*pi*frequency_local source = mag(ai)*sin((sim_time - delay(ai))*omega) if (term_index == mass_label) then - source = source/c + foc_length_factor*mag(ai)*(cos((sim_time - delay(ai))*omega) - 1d0)/omega + 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 - source = mag(ai)*dexp(-0.5d0*((sim_time - delay(ai))**2d0)/(gauss_sigma_time_local**2d0)) + source = mag(ai)*dexp(-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)*dsqrt(pi/2)*gauss_sigma_time_local* & - (erf((sim_time - delay(ai))/(dsqrt(2d0)*gauss_sigma_time_local)) + 1) + (erf((sim_time - delay(ai))/(dsqrt(2._wp)*gauss_sigma_time_local)) + 1) end if elseif (pulse(ai) == 3) then ! Square wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return - omega = 2d0*pi*frequency_local + omega = 2._wp*pi*frequency_local sine_wave = sin((sim_time - delay(ai))*omega) - source = mag(ai)*sign(1d0, sine_wave) + source = mag(ai)*sign(1._wp, sine_wave) ! Prevent max-norm differences due to compilers to pass CI if (abs(sine_wave) < 1d-2) then @@ -396,8 +396,8 @@ contains integer :: j, k, l, ai integer :: count integer :: dim - real(kind(0d0)) :: source_spatial, angle, xyz_to_r_ratios(3) - real(kind(0d0)), parameter :: threshold = 1d-10 + real(wp) :: source_spatial, angle, xyz_to_r_ratios(3) + real(wp), parameter :: threshold = 1d-10 if (n == 0) then dim = 1 @@ -493,10 +493,10 @@ contains !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios) integer, intent(in) :: j, k, l, ai - real(kind(0d0)), dimension(3), intent(in) :: loc - real(kind(0d0)), intent(out) :: source, angle, xyz_to_r_ratios(3) + real(wp), dimension(3), intent(in) :: loc + real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - real(kind(0d0)) :: sig, r(3) + real(wp) :: sig, r(3) ! Calculate sig spatial support width if (n == 0) then @@ -529,22 +529,22 @@ contains !! @param source Source term amplitude subroutine s_source_spatial_planar(ai, sig, r, source) integer, intent(in) :: ai - real(kind(0d0)), intent(in) :: sig, r(3) - real(kind(0d0)), intent(out) :: source + real(wp), intent(in) :: sig, r(3) + real(wp), intent(out) :: source - real(kind(0d0)) :: dist + real(wp) :: dist - source = 0d0 + source = 0._wp if (support(ai) == 1) then ! 1D - source = 1d0/(dsqrt(2d0*pi)*sig/2d0)*dexp(-0.5d0*(r(1)/(sig/2d0))**2d0) + source = 1._wp/(dsqrt(2._wp*pi)*sig/2._wp)*dexp(-0.5_wp*(r(1)/(sig/2._wp))**2._wp) elseif (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)))**2d0 + (r(2) - dist*sin(dir(ai)))**2d0 < 0.25d0*length(ai)**2d0) then ! |r - dist*e| < length/2 - if (support(ai) /= 3 .or. abs(r(3)) < 0.25d0*height(ai)) then ! additional height constraint for 3D - source = 1d0/(dsqrt(2d0*pi)*sig/2d0)*dexp(-0.5d0*(dist/(sig/2d0))**2d0) + 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/(dsqrt(2._wp*pi)*sig/2._wp)*dexp(-0.5_wp*(dist/(sig/2._wp))**2._wp) end if end if end if @@ -559,34 +559,34 @@ contains !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios) integer, intent(in) :: ai - real(kind(0d0)), intent(in) :: sig, r(3) - real(kind(0d0)), intent(out) :: source, angle, xyz_to_r_ratios(3) + real(wp), intent(in) :: sig, r(3) + real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - real(kind(0d0)) :: current_angle, angle_half_aperture, dist, norm + real(wp) :: current_angle, angle_half_aperture, dist, norm - source = 0d0 ! If not affected by transducer - angle = 0d0 - xyz_to_r_ratios = 0d0 + 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 current_angle = -atan(r(2)/(foc_length(ai) - r(1))) - angle_half_aperture = asin((aperture(ai)/2d0)/(foc_length(ai))) + angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) if (abs(current_angle) < angle_half_aperture .and. r(1) < foc_length(ai)) then - dist = foc_length(ai) - dsqrt(r(2)**2d0 + (foc_length(ai) - r(1))**2d0) - source = 1d0/(dsqrt(2d0*pi)*sig/2d0)*dexp(-0.5d0*(dist/(sig/2d0))**2d0) + dist = foc_length(ai) - dsqrt(r(2)**2._wp + (foc_length(ai) - r(1))**2._wp) + source = 1._wp/(dsqrt(2._wp*pi)*sig/2._wp)*dexp(-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 current_angle = -atan(dsqrt(r(2)**2 + r(3)**2)/(foc_length(ai) - r(1))) - angle_half_aperture = asin((aperture(ai)/2d0)/(foc_length(ai))) + angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) if (abs(current_angle) < angle_half_aperture .and. r(1) < foc_length(ai)) then - dist = foc_length(ai) - dsqrt(r(2)**2d0 + r(3)**2d0 + (foc_length(ai) - r(1))**2d0) - source = 1d0/(dsqrt(2d0*pi)*sig/2d0)*dexp(-0.5d0*(dist/(sig/2d0))**2d0) + dist = foc_length(ai) - dsqrt(r(2)**2._wp + r(3)**2._wp + (foc_length(ai) - r(1))**2._wp) + source = 1._wp/(dsqrt(2._wp*pi)*sig/2._wp)*dexp(-0.5_wp*(dist/(sig/2._wp))**2._wp) - norm = dsqrt(r(2)**2d0 + r(3)**2d0 + (foc_length(ai) - r(1))**2d0) + norm = dsqrt(r(2)**2._wp + r(3)**2._wp + (foc_length(ai) - r(1))**2._wp) xyz_to_r_ratios(1) = -(r(1) - foc_length(ai))/norm xyz_to_r_ratios(2) = -r(2)/norm xyz_to_r_ratios(3) = -r(3)/norm @@ -604,14 +604,14 @@ contains !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) integer, intent(in) :: ai - real(kind(0d0)), intent(in) :: sig, r(3) - real(kind(0d0)), intent(out) :: source, angle, xyz_to_r_ratios(3) + 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(kind(0d0)) :: current_angle, angle_half_aperture, angle_per_elem, dist - real(kind(0d0)) :: angle_min, angle_max, norm - real(kind(0d0)) :: poly_side_length, aperture_element_3D, angle_elem - real(kind(0d0)) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center + real(wp) :: current_angle, angle_half_aperture, angle_per_elem, dist + real(wp) :: angle_min, angle_max, norm + real(wp) :: poly_side_length, aperture_element_3D, angle_elem + real(wp) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center if (element_on(ai) == 0) then ! Full transducer elem_min = 1 @@ -621,22 +621,22 @@ contains elem_max = element_on(ai) end if - source = 0d0 ! If not affected by any transducer element - angle = 0d0 - xyz_to_r_ratios = 0d0 + 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 current_angle = -atan(r(2)/(foc_length(ai) - r(1))) - angle_half_aperture = asin((aperture(ai)/2d0)/(foc_length(ai))) - angle_per_elem = (2d0*angle_half_aperture - (num_elements(ai) - 1d0)*element_spacing_angle(ai))/num_elements(ai) - dist = foc_length(ai) - dsqrt(r(2)**2d0 + (foc_length(ai) - r(1))**2d0) + 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) + dist = foc_length(ai) - dsqrt(r(2)**2._wp + (foc_length(ai) - r(1))**2._wp) do elem = elem_min, elem_max - angle_max = angle_half_aperture - (element_spacing_angle(ai) + angle_per_elem)*(elem - 1d0) + angle_max = angle_half_aperture - (element_spacing_angle(ai) + angle_per_elem)*(elem - 1._wp) angle_min = angle_max - angle_per_elem if (current_angle > angle_min .and. current_angle < angle_max .and. r(1) < foc_length(ai)) then - source = dexp(-0.5d0*(dist/(sig/2d0))**2d0)/(dsqrt(2d0*pi)*sig/2d0) + source = dexp(-0.5_wp*(dist/(sig/2._wp))**2._wp)/(dsqrt(2._wp*pi)*sig/2._wp) angle = current_angle exit ! Assume elements don't overlap end if @@ -646,10 +646,10 @@ contains poly_side_length = aperture(ai)*sin(pi/num_elements(ai)) aperture_element_3D = poly_side_length*element_polygon_ratio(ai) f = foc_length(ai) - half_apert = aperture(ai)/2d0 + half_apert = aperture(ai)/2._wp do elem = elem_min, elem_max - angle_elem = 2d0*pi*real(elem, kind(0d0))/real(num_elements(ai), kind(0d0)) + rotate_angle(ai) + angle_elem = 2._wp*pi*real(elem, wp)/real(num_elements(ai), wp) + rotate_angle(ai) ! Point 2 is the elem center x2 = f - dsqrt(f**2 - half_apert**2) @@ -658,17 +658,17 @@ contains ! Construct a plane normal to the line from the focal point to the elem center, ! Point 3 is the intercept of the plane and the line from the focal point to the current location - C = f**2d0/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step + C = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step x3 = C*(r(1) - f) + f y3 = C*r(2) z3 = C*r(3) - dist_interp_to_elem_center = dsqrt((x2 - x3)**2d0 + (y2 - y3)**2d0 + (z2 - z3)**2d0) - if ((dist_interp_to_elem_center < aperture_element_3D/2d0) .and. (r(1) < f)) then - dist = dsqrt((x3 - r(1))**2d0 + (y3 - r(2))**2d0 + (z3 - r(3))**2d0) - source = dexp(-0.5d0*(dist/(sig/2d0))**2d0)/(dsqrt(2d0*pi)*sig/2d0) + dist_interp_to_elem_center = dsqrt((x2 - x3)**2._wp + (y2 - y3)**2._wp + (z2 - z3)**2._wp) + if ((dist_interp_to_elem_center < aperture_element_3D/2._wp) .and. (r(1) < f)) then + dist = dsqrt((x3 - r(1))**2._wp + (y3 - r(2))**2._wp + (z3 - r(3))**2._wp) + source = dexp(-0.5_wp*(dist/(sig/2._wp))**2._wp)/(dsqrt(2._wp*pi)*sig/2._wp) - norm = dsqrt(r(2)**2d0 + r(3)**2d0 + (f - r(1))**2d0) + norm = dsqrt(r(2)**2._wp + r(3)**2._wp + (f - r(1))**2._wp) xyz_to_r_ratios(1) = -(r(1) - f)/norm xyz_to_r_ratios(2) = -r(2)/norm xyz_to_r_ratios(3) = -r(3)/norm @@ -688,8 +688,8 @@ contains !$acc routine seq logical, intent(in) :: freq_conv_flag integer, intent(in) :: ai - real(kind(0d0)), intent(in) :: c - real(kind(0d0)) :: f_frequency_local + real(wp), intent(in) :: c + real(wp) :: f_frequency_local if (freq_conv_flag) then f_frequency_local = c/wavelength(ai) @@ -707,8 +707,8 @@ contains !$acc routine seq logical, intent(in) :: gauss_conv_flag integer, intent(in) :: ai - real(kind(0d0)), intent(in) :: c - real(kind(0d0)) :: f_gauss_sigma_time_local + real(wp), intent(in) :: c + real(wp) :: f_gauss_sigma_time_local if (gauss_conv_flag) then f_gauss_sigma_time_local = gauss_sigma_dist(ai)/c diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 490f0f45bb..8a807740ca 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -25,10 +25,10 @@ module m_body_forces s_finalize_body_forces_module #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), rhoM) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), rhoM) !$acc declare link(rhoM) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: rhoM + real(wp), allocatable, dimension(:, :, :) :: rhoM !$acc declare create(rhoM) #endif @@ -63,7 +63,7 @@ contains !> This subroutine computes the acceleration at time t subroutine s_compute_acceleration(t) - real(kind(0d0)), intent(in) :: t + real(wp), intent(in) :: t if (m > 0) then accel_bf(1) = g_x + k_x*sin(w_x*t - p_x) @@ -91,7 +91,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - rhoM(j, k, l) = 0d0 + 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) @@ -122,7 +122,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - rhs_vf(i)%sf(j, k, l) = 0d0 + rhs_vf(i)%sf(j, k, l) = 0._wp end do end do end do diff --git a/src/simulation/m_boundary_conditions.fpp b/src/simulation/m_boundary_conditions.fpp index 266be8ed00..a15b144478 100644 --- a/src/simulation/m_boundary_conditions.fpp +++ b/src/simulation/m_boundary_conditions.fpp @@ -30,7 +30,7 @@ contains subroutine s_populate_variables_buffers(q_prim_vf, pb, mv) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer :: bc_loc, bc_dir @@ -217,7 +217,7 @@ contains subroutine s_ghost_cell_extrapolation(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -328,7 +328,7 @@ contains subroutine s_symmetry(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -610,7 +610,7 @@ contains subroutine s_periodic(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -830,7 +830,7 @@ contains subroutine s_axis(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -903,7 +903,7 @@ contains subroutine s_slip_wall(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -920,7 +920,7 @@ contains 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) + 2d0*bc_x%vb1 + -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) @@ -939,7 +939,7 @@ contains 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) + 2d0*bc_x%ve1 + -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) @@ -963,7 +963,7 @@ contains do l = -buff_size, m + buff_size if (i == momxb + 1) then q_prim_vf(i)%sf(l, -j, k) = & - -q_prim_vf(i)%sf(l, j - 1, k) + 2d0*bc_y%vb2 + -q_prim_vf(i)%sf(l, j - 1, k) + 2._wp*bc_y%vb2 else q_prim_vf(i)%sf(l, -j, k) = & q_prim_vf(i)%sf(l, 0, k) @@ -982,7 +982,7 @@ contains do l = -buff_size, m + buff_size if (i == momxb + 1) then q_prim_vf(i)%sf(l, n + j, k) = & - -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2d0*bc_y%ve2 + -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2._wp*bc_y%ve2 else q_prim_vf(i)%sf(l, n + j, k) = & q_prim_vf(i)%sf(l, n, k) @@ -1006,7 +1006,7 @@ contains do k = -buff_size, m + buff_size if (i == momxe) then q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2d0*bc_z%vb3 + -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) @@ -1025,7 +1025,7 @@ contains do k = -buff_size, m + 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)) + 2d0*bc_z%ve3 + -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) @@ -1045,7 +1045,7 @@ contains subroutine s_no_slip_wall(q_prim_vf, pb, mv, bc_dir, bc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i @@ -1062,13 +1062,13 @@ contains 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) + 2d0*bc_x%vb1 + -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) + 2d0*bc_x%vb2 + -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) + 2d0*bc_x%vb3 + -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) @@ -1087,13 +1087,13 @@ contains 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) + 2d0*bc_x%ve1 + -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) + 2d0*bc_x%ve2 + -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) + 2d0*bc_x%ve3 + -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) @@ -1117,13 +1117,13 @@ contains do l = -buff_size, m + buff_size if (i == momxb) then q_prim_vf(i)%sf(l, -j, k) = & - -q_prim_vf(i)%sf(l, j - 1, k) + 2d0*bc_y%vb1 + -q_prim_vf(i)%sf(l, j - 1, k) + 2._wp*bc_y%vb1 elseif (i == momxb + 1 .and. num_dims > 1) then q_prim_vf(i)%sf(l, -j, k) = & - -q_prim_vf(i)%sf(l, j - 1, k) + 2d0*bc_y%vb2 + -q_prim_vf(i)%sf(l, j - 1, k) + 2._wp*bc_y%vb2 elseif (i == momxb + 2 .and. num_dims > 2) then q_prim_vf(i)%sf(l, -j, k) = & - -q_prim_vf(i)%sf(l, j - 1, k) + 2d0*bc_y%vb3 + -q_prim_vf(i)%sf(l, j - 1, k) + 2._wp*bc_y%vb3 else q_prim_vf(i)%sf(l, -j, k) = & q_prim_vf(i)%sf(l, 0, k) @@ -1142,13 +1142,13 @@ contains do l = -buff_size, m + buff_size if (i == momxb) then q_prim_vf(i)%sf(l, n + j, k) = & - -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2d0*bc_y%ve1 + -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2._wp*bc_y%ve1 elseif (i == momxb + 1 .and. num_dims > 1) then q_prim_vf(i)%sf(l, n + j, k) = & - -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2d0*bc_y%ve2 + -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2._wp*bc_y%ve2 elseif (i == momxb + 2 .and. num_dims > 2) then q_prim_vf(i)%sf(l, n + j, k) = & - -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2d0*bc_y%ve3 + -q_prim_vf(i)%sf(l, n - (j - 1), k) + 2._wp*bc_y%ve3 else q_prim_vf(i)%sf(l, n + j, k) = & q_prim_vf(i)%sf(l, n, k) @@ -1172,13 +1172,13 @@ contains do k = -buff_size, m + buff_size if (i == momxb) then q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2d0*bc_z%vb1 + -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) + 2d0*bc_z%vb2 + -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) + 2d0*bc_z%vb3 + -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) @@ -1197,13 +1197,13 @@ contains do k = -buff_size, m + 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)) + 2d0*bc_z%ve1 + -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)) + 2d0*bc_z%ve2 + -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)) + 2d0*bc_z%ve3 + -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) @@ -1222,7 +1222,7 @@ contains subroutine s_qbmm_extrapolation(pb, mv, bc_dir, bc_loc) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: bc_dir, bc_loc integer :: j, k, l, q, i diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 21f7aaf58c..190dd700db 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -21,19 +21,19 @@ module m_bubbles implicit none - real(kind(0.d0)) :: chi_vw !< Bubble wall properties (Ando 2010) - real(kind(0.d0)) :: k_mw !< Bubble wall properties (Ando 2010) - real(kind(0.d0)) :: rho_mw !< Bubble wall properties (Ando 2010) + real(kind(0._wp)) :: chi_vw !< Bubble wall properties (Ando 2010) + real(kind(0._wp)) :: k_mw !< Bubble wall properties (Ando 2010) + real(kind(0._wp)) :: rho_mw !< Bubble wall properties (Ando 2010) !$acc declare create(chi_vw, k_mw, rho_mw) #ifdef CRAY_ACC_WAR !> @name Bubble dynamic source terms !> @{ - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), bub_adv_src) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), bub_adv_src) !$acc declare link(bub_adv_src) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), bub_r_src, bub_v_src, bub_p_src, bub_m_src) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), bub_r_src, bub_v_src, bub_p_src, bub_m_src) !$acc declare link(bub_r_src, bub_v_src, bub_p_src, bub_m_src) type(scalar_field) :: divu !< matrix for div(u) @@ -42,8 +42,8 @@ module m_bubbles @:CRAY_DECLARE_GLOBAL(integer, dimension(:), rs, vs, ms, ps) !$acc declare link(rs, vs, ms, ps) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: bub_adv_src - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: 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 !$acc 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) @@ -104,19 +104,19 @@ contains !! @param q_cons_vf is the conservative variable subroutine s_comp_alpha_from_n(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(kind(0d0)) :: nR3bar - integer(kind(0d0)) :: i, j, k, l + real(wp) :: nR3bar + integer(wp) :: i, j, k, l !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p do k = 0, n do j = 0, m - nR3bar = 0d0 + nR3bar = 0._wp !$acc loop seq do i = 1, nb - nR3bar = nR3bar + weight(i)*(q_cons_vf(rs(i))%sf(j, k, l))**3d0 + nR3bar = nR3bar + weight(i)*(q_cons_vf(rs(i))%sf(j, k, l))**3._wp end do - q_cons_vf(alf_idx)%sf(j, k, l) = (4d0*pi*nR3bar)/(3d0*q_cons_vf(n_idx)%sf(j, k, l)**2d0) + q_cons_vf(alf_idx)%sf(j, k, l) = (4._wp*pi*nR3bar)/(3._wp*q_cons_vf(n_idx)%sf(j, k, l)**2._wp) end do end do end do @@ -137,7 +137,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - divu%sf(j, k, l) = 0d0 + divu%sf(j, k, l) = 0._wp divu%sf(j, k, l) = & 5d-1/dx(j)*(q_prim_vf(contxe + idir)%sf(j + 1, k, l) - & q_prim_vf(contxe + idir)%sf(j - 1, k, l)) @@ -189,39 +189,39 @@ contains integer, intent(in) :: t_step type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - real(kind(0d0)) :: rddot - real(kind(0d0)) :: pb, mv, vflux, pbdot - real(kind(0d0)) :: n_tait, B_tait + real(wp) :: rddot + real(wp) :: pb, mv, vflux, pbdot + real(wp) :: n_tait, B_tait - real(kind(0d0)), dimension(nb) :: Rtmp, Vtmp - real(kind(0d0)) :: myR, myV, alf, myP, myRho, R2Vav, R3 - real(kind(0d0)), dimension(num_fluids) :: myalpha, myalpha_rho - real(kind(0d0)) :: start, finish + real(wp), dimension(nb) :: Rtmp, Vtmp + real(wp) :: myR, myV, alf, myP, myRho, R2Vav, R3 + real(wp), dimension(num_fluids) :: myalpha, myalpha_rho + real(wp) :: start, finish - real(kind(0d0)) :: nbub !< Bubble number density + real(wp) :: nbub !< Bubble number density - real(kind(0d0)), dimension(2) :: Re !< Reynolds number + real(wp), dimension(2) :: Re !< Reynolds number integer :: i, j, k, l, q, ii !< Loop variables integer :: ndirs !< Number of coordinate directions - real(kind(0d0)) :: err1, err2, err3, err4, err5 !< Error estimates for adaptive time stepping - real(kind(0d0)) :: t_new !< Updated time step size - real(kind(0d0)) :: h !< Time step size - real(kind(0d0)), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop + real(wp) :: err1, err2, err3, err4, err5 !< Error estimates for adaptive time stepping + real(wp) :: t_new !< Updated time step size + real(wp) :: 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 !$acc parallel loop collapse(3) gang vector default(present) do l = 0, p do k = 0, n do j = 0, m - bub_adv_src(j, k, l) = 0d0 + bub_adv_src(j, k, l) = 0._wp !$acc loop seq do q = 1, nb - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 + bub_r_src(j, k, l, q) = 0._wp + bub_v_src(j, k, l, q) = 0._wp + bub_p_src(j, k, l, q) = 0._wp + bub_m_src(j, k, l, q) = 0._wp end do end do end do @@ -241,25 +241,25 @@ contains Vtmp(q) = q_prim_vf(vs(q))%sf(j, k, l) end do - R3 = 0d0 + R3 = 0._wp !$acc loop seq do q = 1, nb - R3 = R3 + weight(q)*Rtmp(q)**3.d0 + R3 = R3 + weight(q)*Rtmp(q)**3._wp end do - nbub = (3.d0/(4.d0*pi))*q_prim_vf(alf_idx)%sf(j, k, l)/R3 + nbub = (3._wp/(4._wp*pi))*q_prim_vf(alf_idx)%sf(j, k, l)/R3 end if if (.not. adap_dt) then - R2Vav = 0d0 + R2Vav = 0._wp !$acc loop seq do q = 1, nb - R2Vav = R2Vav + weight(q)*Rtmp(q)**2.d0*Vtmp(q) + R2Vav = R2Vav + weight(q)*Rtmp(q)**2._wp*Vtmp(q) end do - bub_adv_src(j, k, l) = 4.d0*pi*nbub*R2Vav + bub_adv_src(j, k, l) = 4._wp*pi*nbub*R2Vav end if !$acc loop seq @@ -271,9 +271,9 @@ contains myalpha(ii) = q_cons_vf(advxb + ii - 1)%sf(j, k, l) end do - myRho = 0d0 - n_tait = 0d0 - B_tait = 0d0 + myRho = 0._wp + n_tait = 0._wp + B_tait = 0._wp if (mpp_lim .and. (num_fluids > 2)) then !$acc loop seq @@ -295,7 +295,7 @@ contains B_tait = pi_infs(1)/pi_fac end if - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' + n_tait = 1._wp/n_tait + 1._wp !make this the usual little 'gamma' B_tait = B_tait*(n_tait - 1)/n_tait ! make this the usual pi_inf myRho = q_prim_vf(1)%sf(j, k, l) @@ -312,9 +312,9 @@ contains pbdot = f_bpres_dot(vflux, myR, myV, pb, mv, q) bub_p_src(j, k, l, q) = nbub*pbdot - bub_m_src(j, k, l, q) = nbub*vflux*4.d0*pi*(myR**2.d0) + bub_m_src(j, k, l, q) = nbub*vflux*4._wp*pi*(myR**2._wp) else - pb = 0d0; mv = 0d0; vflux = 0d0; pbdot = 0d0 + pb = 0._wp; mv = 0._wp; vflux = 0._wp; pbdot = 0._wp end if ! Adaptive time stepping @@ -325,10 +325,10 @@ contains bub_adv_src(j, k, l), divu%sf(j, k, l), h) ! Advancing one step - t_new = 0d0 + t_new = 0._wp do while (.true.) - if (t_new + h > 0.5d0*dt) then - h = 0.5d0*dt - t_new + if (t_new + h > 0.5_wp*dt) then + h = 0.5_wp*dt - t_new end if ! Advancing one sub-step @@ -342,26 +342,26 @@ contains ! Advance one sub-step by advancing two half steps call s_advance_substep(myRho, myP, myR, myV, R0(q), & pb, pbdot, alf, n_tait, B_tait, & - bub_adv_src(j, k, l), divu%sf(j, k, l), 0.5d0*h, & + bub_adv_src(j, k, l), divu%sf(j, k, l), 0.5_wp*h, & myR_tmp2, myV_tmp2, err2) call s_advance_substep(myRho, myP, myR_tmp2(4), myV_tmp2(4), R0(q), & pb, pbdot, alf, n_tait, B_tait, & - bub_adv_src(j, k, l), divu%sf(j, k, l), 0.5d0*h, & + bub_adv_src(j, k, l), divu%sf(j, k, l), 0.5_wp*h, & myR_tmp2, myV_tmp2, err3) err4 = abs((myR_tmp1(4) - myR_tmp2(4))/myR_tmp1(4)) err5 = abs((myV_tmp1(4) - myV_tmp2(4))/myV_tmp1(4)) - if (abs(myV_tmp1(4)) < 1e-12) err5 = 0d0 + if (abs(myV_tmp1(4)) < 1e-12) err5 = 0._wp ! Determine acceptance/rejection and update step size ! Rule 1: err1, err2, err3 < tol - ! Rule 2: myR_tmp1(4) > 0d0 + ! Rule 2: myR_tmp1(4) > 0._wp ! Rule 3: abs((myR_tmp1(4) - myR_tmp2(4))/myR) < tol ! Rule 4: abs((myV_tmp1(4) - myV_tmp2(4))/myV) < tol if ((err1 <= 1d-4) .and. (err2 <= 1d-4) .and. (err3 <= 1d-4) & .and. (err4 < 1d-4) .and. (err5 < 1d-4) & - .and. myR_tmp1(4) > 0d0) then + .and. myR_tmp1(4) > 0._wp) then ! Accepted. Finalize the sub-step t_new = t_new + h @@ -371,22 +371,22 @@ contains myV = myV_tmp1(4) ! Update step size for the next sub-step - h = h*min(2d0, max(0.5d0, (1d-4/err1)**(1d0/3d0))) + h = h*min(2._wp, max(0.5_wp, (1d-4/err1)**(1._wp/3._wp))) exit else ! Rejected. Update step size for the next try on sub-step if (err2 <= 1d-4) then - h = 0.5d0*h + h = 0.5_wp*h else - h = 0.25d0*h + h = 0.25_wp*h end if end if end do ! Exit the loop if the final time reached dt - if (t_new == 0.5d0*dt) exit + if (t_new == 0.5_wp*dt) exit end do @@ -402,12 +402,12 @@ contains end if if (alf < 1.d-11) then - bub_adv_src(j, k, l) = 0d0 - bub_r_src(j, k, l, q) = 0d0 - bub_v_src(j, k, l, q) = 0d0 + bub_adv_src(j, k, l) = 0._wp + bub_r_src(j, k, l, q) = 0._wp + bub_v_src(j, k, l, q) = 0._wp if (.not. polytropic) then - bub_p_src(j, k, l, q) = 0d0 - bub_m_src(j, k, l, q) = 0d0 + bub_p_src(j, k, l, q) = 0._wp + bub_m_src(j, k, l, q) = 0._wp end if end if end do @@ -457,13 +457,13 @@ contains subroutine s_initialize_adap_dt(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & fntait, fBtait, f_bub_adv_src, f_divu, h) !$acc routine seq - real(kind(0d0)), intent(IN) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf - real(kind(0d0)), intent(IN) :: fntait, fBtait, f_bub_adv_src, f_divu - real(kind(0d0)), intent(out) :: h + 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(out) :: h - real(kind(0d0)) :: h0, h1, h_min !< Time step size - real(kind(0d0)) :: d0, d1, d2 !< norms - real(kind(0d0)), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration + real(wp) :: h0, h1, h_min !< Time step size + real(wp) :: d0, d1, d2 !< norms + 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) @@ -474,8 +474,8 @@ contains f_bub_adv_src, f_divu) ! Compute d0 = ||y0|| and d1 = ||f(x0,y0)|| - d0 = DSQRT((myR_tmp(1)**2d0 + myV_tmp(1)**2d0)/2d0) - d1 = DSQRT((myV_tmp(1)**2d0 + myA_tmp(1)**2d0)/2d0) + d0 = DSQRT((myR_tmp(1)**2._wp + myV_tmp(1)**2._wp)/2._wp) + d1 = DSQRT((myV_tmp(1)**2._wp + myA_tmp(1)**2._wp)/2._wp) if (d0 < 1d-5 .or. d1 < 1d-5) then h0 = 1d-6 else @@ -490,18 +490,18 @@ contains f_bub_adv_src, f_divu) ! Compute d2 = ||f(x0+h0,y0+h0*f(x0,y0))-f(x0,y0)||/h0 - d2 = DSQRT(((myV_tmp(2) - myV_tmp(1))**2d0 + (myA_tmp(2) - myA_tmp(1))**2d0)/2d0)/h0 + d2 = DSQRT(((myV_tmp(2) - myV_tmp(1))**2._wp + (myA_tmp(2) - myA_tmp(1))**2._wp)/2._wp)/h0 ! Set h1 = (0.01/max(d1,d2))^{1/(p+1)} ! if max(d1,d2) < 1e-15, h1 = max(1e-6, h0*1e-3) if (max(d1, d2) < 1d-15) then h1 = max(1d-6, h0*1d-3) else - h1 = (1d-2/max(d1, d2))**(1d0/3d0) + h1 = (1d-2/max(d1, d2))**(1._wp/3._wp) end if ! Set h = min(100*h0,h1) - h = min(100d0*h0, h1) + h = min(100._wp*h0, h1) end subroutine s_initialize_adap_dt @@ -526,12 +526,12 @@ contains fntait, fBtait, f_bub_adv_src, f_divu, h, & myR_tmp, myV_tmp, err) !$acc routine seq - real(kind(0d0)), intent(IN) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf - real(kind(0d0)), intent(IN) :: fntait, fBtait, f_bub_adv_src, f_divu, h - real(kind(0d0)), dimension(4), intent(OUT) :: myR_tmp, myV_tmp - real(kind(0d0)), dimension(4) :: myA_tmp - real(kind(0d0)), intent(OUT) :: err - real(kind(0d0)) :: err_R, err_V + 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 + real(wp), dimension(4), intent(OUT) :: myR_tmp, myV_tmp + real(wp), dimension(4) :: myA_tmp + real(wp), intent(OUT) :: err + real(wp) :: err_R, err_V ! Stage 0 myR_tmp(1) = fR @@ -548,25 +548,25 @@ contains f_bub_adv_src, f_divu) ! Stage 2 - myR_tmp(3) = myR_tmp(1) + (h/4d0)*(myV_tmp(1) + myV_tmp(2)) - myV_tmp(3) = myV_tmp(1) + (h/4d0)*(myA_tmp(1) + myA_tmp(2)) + myR_tmp(3) = myR_tmp(1) + (h/4._wp)*(myV_tmp(1) + myV_tmp(2)) + myV_tmp(3) = myV_tmp(1) + (h/4._wp)*(myA_tmp(1) + myA_tmp(2)) myA_tmp(3) = f_rddot(fRho, fP, myR_tmp(3), myV_tmp(3), fR0, & fpb, fpbdot, alf, fntait, fBtait, & f_bub_adv_src, f_divu) ! Stage 3 - myR_tmp(4) = myR_tmp(1) + (h/6d0)*(myV_tmp(1) + myV_tmp(2) + 4d0*myV_tmp(3)) - myV_tmp(4) = myV_tmp(1) + (h/6d0)*(myA_tmp(1) + myA_tmp(2) + 4d0*myA_tmp(3)) + myR_tmp(4) = myR_tmp(1) + (h/6._wp)*(myV_tmp(1) + myV_tmp(2) + 4._wp*myV_tmp(3)) + myV_tmp(4) = myV_tmp(1) + (h/6._wp)*(myA_tmp(1) + myA_tmp(2) + 4._wp*myA_tmp(3)) myA_tmp(4) = f_rddot(fRho, fP, myR_tmp(4), myV_tmp(4), fR0, & fpb, fpbdot, alf, fntait, fBtait, & f_bub_adv_src, f_divu) ! Estimate error - err_R = (-5d0*h/24d0)*(myV_tmp(2) + myV_tmp(3) - 2d0*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 = (-5d0*h/24d0)*(myA_tmp(2) + myA_tmp(3) - 2d0*myA_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 = DSQRT((err_R**2d0 + err_V**2d0)/2d0) + err = DSQRT((err_R**2._wp + err_V**2._wp)/2._wp) end subroutine s_advance_substep @@ -577,14 +577,14 @@ contains !! @param fpb Internal bubble pressure function f_cpbw(fR0, fR, fV, fpb) !$acc routine seq - real(kind(0d0)), intent(in) :: fR0, fR, fV, fpb + real(wp), intent(in) :: fR0, fR, fV, fpb - real(kind(0d0)) :: f_cpbw + real(wp) :: f_cpbw if (polytropic) then - f_cpbw = (Ca + 2.d0/Web/fR0)*((fR0/fR)**(3.d0*gam)) - Ca - 4.d0*Re_inv*fV/fR - 2.d0/(fR*Web) + f_cpbw = (Ca + 2._wp/Web/fR0)*((fR0/fR)**(3._wp*gam)) - Ca - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) else - f_cpbw = fpb - 1.d0 - 4.d0*Re_inv*fV/fR - 2.d0/(fR*Web) + f_cpbw = fpb - 1._wp - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) end if end function f_cpbw @@ -596,16 +596,16 @@ contains !! @param fBtait Tait EOS parameter function f_H(fCpbw, fCpinf, fntait, fBtait) !$acc routine seq - real(kind(0d0)), intent(in) :: fCpbw, fCpinf, fntait, fBtait + real(wp), intent(in) :: fCpbw, fCpinf, fntait, fBtait - real(kind(0d0)) :: tmp1, tmp2, tmp3 - real(kind(0d0)) :: f_H + real(wp) :: tmp1, tmp2, tmp3 + real(wp) :: f_H - tmp1 = (fntait - 1.d0)/fntait - tmp2 = (fCpbw/(1.d0 + fBtait) + 1.d0)**tmp1 - tmp3 = (fCpinf/(1.d0 + fBtait) + 1.d0)**tmp1 + tmp1 = (fntait - 1._wp)/fntait + tmp2 = (fCpbw/(1._wp + fBtait) + 1._wp)**tmp1 + tmp3 = (fCpinf/(1._wp + fBtait) + 1._wp)**tmp1 - f_H = (tmp2 - tmp3)*fntait*(1.d0 + fBtait)/(fntait - 1.d0) + f_H = (tmp2 - tmp3)*fntait*(1._wp + fBtait)/(fntait - 1._wp) end function f_H @@ -616,16 +616,16 @@ contains !! @param fH Bubble enthalpy function f_cgas(fCpinf, fntait, fBtait, fH) !$acc routine seq - real(kind(0d0)), intent(in) :: fCpinf, fntait, fBtait, fH + real(wp), intent(in) :: fCpinf, fntait, fBtait, fH - real(kind(0d0)) :: tmp - real(kind(0d0)) :: f_cgas + real(wp) :: tmp + real(wp) :: f_cgas ! get sound speed for Gilmore equations "C" -> c_gas - tmp = (fCpinf/(1.d0 + fBtait) + 1.d0)**((fntait - 1.d0)/fntait) - tmp = fntait*(1.d0 + fBtait)*tmp + tmp = (fCpinf/(1._wp + fBtait) + 1._wp)**((fntait - 1._wp)/fntait) + tmp = fntait*(1._wp + fBtait)*tmp - f_cgas = dsqrt(tmp + (fntait - 1.d0)*fH) + f_cgas = dsqrt(tmp + (fntait - 1._wp)*fH) end function f_cgas @@ -639,17 +639,17 @@ contains !! @param divu Divergence of velocity function f_cpinfdot(fRho, fP, falf, fntait, fBtait, advsrc, divu) !$acc routine seq - real(kind(0d0)), intent(in) :: fRho, fP, falf, fntait, fBtait, advsrc, divu + real(wp), intent(in) :: fRho, fP, falf, fntait, fBtait, advsrc, divu - real(kind(0d0)) :: c2_liquid - real(kind(0d0)) :: 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)) if (mpp_lim) then c2_liquid = fntait*(fP + fBtait)/fRho else - c2_liquid = fntait*(fP + fBtait)/(fRho*(1.d0 - falf)) + c2_liquid = fntait*(fP + fBtait)/(fRho*(1._wp - falf)) end if ! \dot{Cp_inf} = rho sound^2 (alf_src - divu) @@ -669,30 +669,30 @@ contains !! @param fpbdot Time derivative of the internal bubble pressure function f_Hdot(fCpbw, fCpinf, fCpinf_dot, fntait, fBtait, fR, fV, fR0, fpbdot) !$acc routine seq - real(kind(0d0)), intent(in) :: fCpbw, fCpinf, fCpinf_dot, fntait, fBtait - real(kind(0d0)), intent(in) :: fR, fV, fR0, fpbdot + real(wp), intent(in) :: fCpbw, fCpinf, fCpinf_dot, fntait, fBtait + real(wp), intent(in) :: fR, fV, fR0, fpbdot - real(kind(0d0)) :: tmp1, tmp2 - real(kind(0d0)) :: f_Hdot + real(wp) :: tmp1, tmp2 + real(wp) :: f_Hdot if (polytropic) then - tmp1 = (fR0/fR)**(3.d0*gam) - tmp1 = -3.d0*gam*(Ca + 2d0/Web/fR0)*tmp1*fV/fR + tmp1 = (fR0/fR)**(3._wp*gam) + tmp1 = -3._wp*gam*(Ca + 2._wp/Web/fR0)*tmp1*fV/fR else tmp1 = fpbdot end if - tmp2 = (2.d0/Web + 4.d0*Re_inv*fV)*fV/(fR**2.d0) + tmp2 = (2._wp/Web + 4._wp*Re_inv*fV)*fV/(fR**2._wp) f_Hdot = & - (fCpbw/(1.d0 + fBtait) + 1.d0)**(-1.d0/fntait)*(tmp1 + tmp2) & - - (fCpinf/(1.d0 + fBtait) + 1.d0)**(-1.d0/fntait)*fCpinf_dot + (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/(1d0+fBtait)+1.d0)**(-1.d0/fntait))*(-3.d0)*gam * & - ! ( (fR0/fR)**(3.d0*gam ))*(fV/fR) + !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.d0+fBtait)+1.d0)**(-1.d0/fntait))*fCpinf_dot + !f_Hdot = f_Hdot - ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot end function f_Hdot @@ -711,11 +711,11 @@ contains !! @param f_divu Divergence of velocity function f_rddot(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu) !$acc routine seq - real(kind(0d0)), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf - real(kind(0d0)), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu + 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(kind(0d0)) :: fCpbw, fCpinf, fCpinf_dot, fH, fHdot, c_gas, c_liquid - real(kind(0d0)) :: 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 @@ -730,7 +730,7 @@ contains ! Keller-Miksis bubbles fCpinf = fP fCpbw = f_cpbw_KM(fR0, fR, fV, fpb) - c_liquid = dsqrt(fntait*(fP + fBtait)/(fRho*(1.d0 - alf))) + c_liquid = dsqrt(fntait*(fP + fBtait)/(fRho*(1._wp - alf))) f_rddot = f_rddot_KM(fpbdot, fCpinf, fCpbw, fRho, fR, fV, fR0, c_liquid) else if (bubble_model == 3) then ! Rayleigh-Plesset bubbles @@ -749,15 +749,15 @@ contains !! @param fCpbw Boundary wall pressure function f_rddot_RP(fCp, fRho, fR, fV, fR0, fCpbw) !$acc routine seq - real(kind(0d0)), intent(in) :: fCp, fRho, fR, fV, fR0, fCpbw + real(wp), intent(in) :: fCp, fRho, fR, fV, fR0, fCpbw - real(kind(0d0)) :: f_rddot_RP + real(wp) :: f_rddot_RP !! rddot = (1/r) ( -3/2 rdot^2 + ((r0/r)^3\gamma - Cp)/rho ) !! rddot = (1/r) ( -3/2 rdot^2 + (tmp1 - Cp)/rho ) !! rddot = (1/r) ( tmp2 ) - f_rddot_RP = (-1.5d0*(fV**2d0) + (fCpbw - fCp)/fRho)/fR + f_rddot_RP = (-1.5_wp*(fV**2._wp) + (fCpbw - fCp)/fRho)/fR end function f_rddot_RP @@ -772,19 +772,19 @@ contains !! @param fBtait Tait EOS parameter function f_rddot_G(fCpbw, fR, fV, fH, fHdot, fcgas, fntait, fBtait) !$acc routine seq - real(kind(0d0)), intent(in) :: fCpbw, fR, fV, fH, fHdot - real(kind(0d0)), intent(in) :: fcgas, fntait, fBtait + real(wp), intent(in) :: fCpbw, fR, fV, fH, fHdot + real(wp), intent(in) :: fcgas, fntait, fBtait - real(kind(0d0)) :: tmp1, tmp2, tmp3 - real(kind(0d0)) :: f_rddot_G + real(wp) :: tmp1, tmp2, tmp3 + real(wp) :: f_rddot_G tmp1 = fV/fcgas - tmp2 = 1.d0 + 4.d0*Re_inv/fcgas/fR*(fCpbw/(1.d0 + fBtait) + 1.d0) & - **(-1.d0/fntait) - tmp3 = 1.5d0*fV**2d0*(tmp1/3.d0 - 1.d0) + fH*(1.d0 + tmp1) & - + fR*fHdot*(1.d0 - 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.d0 - tmp1)*tmp2) + f_rddot_G = tmp3/(fR*(1._wp - tmp1)*tmp2) end function f_rddot_G @@ -795,20 +795,20 @@ contains !! @param fpb Internal bubble pressure function f_cpbw_KM(fR0, fR, fV, fpb) !$acc routine seq - real(kind(0d0)), intent(in) :: fR0, fR, fV, fpb + real(wp), intent(in) :: fR0, fR, fV, fpb - real(kind(0d0)) :: f_cpbw_KM + real(wp) :: f_cpbw_KM if (polytropic) then - f_cpbw_KM = Ca*((fR0/fR)**(3.d0*gam)) - Ca + 1d0 + f_cpbw_KM = Ca*((fR0/fR)**(3._wp*gam)) - Ca + 1._wp if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM + & - (2.d0/(Web*fR0))*((fR0/fR)**(3.d0*gam)) + (2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam)) else f_cpbw_KM = fpb end if - if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM - 2.d0/(fR*Web) - if (.not. f_is_default(Re_inv)) f_cpbw_KM = f_cpbw_KM - 4.d0*Re_inv*fV/fR + if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM - 2._wp/(fR*Web) + if (.not. f_is_default(Re_inv)) f_cpbw_KM = f_cpbw_KM - 4._wp*Re_inv*fV/fR end function f_cpbw_KM @@ -823,32 +823,32 @@ contains !! @param fC Current sound speed function f_rddot_KM(fpbdot, fCp, fCpbw, fRho, fR, fV, fR0, fC) !$acc routine seq - real(kind(0d0)), intent(in) :: fpbdot, fCp, fCpbw - real(kind(0d0)), intent(in) :: fRho, fR, fV, fR0, fC + real(wp), intent(in) :: fpbdot, fCp, fCpbw + real(wp), intent(in) :: fRho, fR, fV, fR0, fC - real(kind(0d0)) :: tmp1, tmp2, cdot_star - real(kind(0d0)) :: f_rddot_KM + real(wp) :: tmp1, tmp2, cdot_star + real(wp) :: f_rddot_KM if (polytropic) then - cdot_star = -3d0*gam*Ca*((fR0/fR)**(3d0*gam))*fV/fR + cdot_star = -3._wp*gam*Ca*((fR0/fR)**(3._wp*gam))*fV/fR if (.not. f_is_default(Web)) cdot_star = cdot_star - & - 3d0*gam*(2d0/(Web*fR0))*((fR0/fR)**(3d0*gam))*fV/fR + 3._wp*gam*(2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam))*fV/fR else cdot_star = fpbdot end if - if (.not. f_is_default(Web)) cdot_star = cdot_star + (2d0/Web)*fV/(fR**2d0) - if (.not. f_is_default(Re_inv)) cdot_star = cdot_star + 4d0*Re_inv*((fV/fR)**2d0) + if (.not. f_is_default(Web)) cdot_star = cdot_star + (2._wp/Web)*fV/(fR**2._wp) + if (.not. f_is_default(Re_inv)) cdot_star = cdot_star + 4._wp*Re_inv*((fV/fR)**2._wp) tmp1 = fV/fC - tmp2 = 1.5d0*(fV**2d0)*(tmp1/3d0 - 1d0) + & - (1d0 + tmp1)*(fCpbw - fCp)/fRho + & + 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*(1d0 - tmp1)) + f_rddot_KM = tmp2/(fR*(1._wp - tmp1)) else - f_rddot_KM = tmp2/(fR*(1d0 - tmp1) + 4d0*Re_inv/(fRho*fC)) + f_rddot_KM = tmp2/(fR*(1._wp - tmp1) + 4._wp*Re_inv/(fRho*fC)) end if end function f_rddot_KM @@ -858,17 +858,17 @@ contains !! @param iR0 Current bubble size index subroutine s_bwproperty(pb, iR0) !$acc routine seq - real(kind(0.d0)), intent(in) :: pb + real(kind(0._wp)), intent(in) :: pb integer, intent(in) :: iR0 - real(kind(0.d0)) :: x_vw + real(kind(0._wp)) :: x_vw ! mass fraction of vapor - chi_vw = 1.d0/(1.d0 + R_v/R_n*(pb/pv - 1.d0)) + chi_vw = 1._wp/(1._wp + R_v/R_n*(pb/pv - 1._wp)) ! mole fraction of vapor & thermal conductivity of gas mixture x_vw = M_n*chi_vw/(M_v + (M_n - M_v)*chi_vw) - k_mw = x_vw*k_v(iR0)/(x_vw + (1.d0 - x_vw)*phi_vn) & - + (1.d0 - x_vw)*k_n(iR0)/(x_vw*phi_nv + 1.d0 - x_vw) + k_mw = x_vw*k_v(iR0)/(x_vw + (1._wp - x_vw)*phi_vn) & + + (1._wp - x_vw)*k_n(iR0)/(x_vw*phi_nv + 1._wp - x_vw) ! gas mixture density rho_mw = pv/(chi_vw*R_v*Tw) @@ -881,20 +881,20 @@ contains !! @param iR0 Bubble size index function f_vflux(fR, fV, fmass_v, iR0) !$acc routine seq - real(kind(0.d0)), intent(in) :: fR - real(kind(0.d0)), intent(in) :: fV - real(kind(0.d0)), intent(in) :: fmass_v + real(kind(0._wp)), intent(in) :: fR + real(kind(0._wp)), intent(in) :: fV + real(kind(0._wp)), intent(in) :: fmass_v integer, intent(in) :: iR0 - real(kind(0.d0)) :: chi_bar - real(kind(0.d0)) :: grad_chi - real(kind(0.d0)) :: f_vflux + real(kind(0._wp)) :: chi_bar + real(kind(0._wp)) :: grad_chi + real(kind(0._wp)) :: f_vflux if (thermal == 3) then !transfer ! constant transfer model chi_bar = fmass_v/(fmass_v + mass_n0(iR0)) grad_chi = -Re_trans_c(iR0)*(chi_bar - chi_vw) - f_vflux = rho_mw*grad_chi/Pe_c/(1.d0 - chi_vw)/fR + f_vflux = rho_mw*grad_chi/Pe_c/(1._wp - chi_vw)/fR else ! polytropic f_vflux = pv*fV/(R_v*Tw) @@ -912,26 +912,26 @@ contains !! @param iR0 Bubble size index function f_bpres_dot(fvflux, fR, fV, fpb, fmass_v, iR0) !$acc routine seq - real(kind(0.d0)), intent(in) :: fvflux - real(kind(0.d0)), intent(in) :: fR - real(kind(0.d0)), intent(in) :: fV - real(kind(0.d0)), intent(in) :: fpb - real(kind(0.d0)), intent(in) :: fmass_v + real(kind(0._wp)), intent(in) :: fvflux + real(kind(0._wp)), intent(in) :: fR + real(kind(0._wp)), intent(in) :: fV + real(kind(0._wp)), intent(in) :: fpb + real(kind(0._wp)), intent(in) :: fmass_v integer, intent(in) :: iR0 - real(kind(0.d0)) :: T_bar - real(kind(0.d0)) :: grad_T - real(kind(0.d0)) :: tmp1, tmp2 - real(kind(0.d0)) :: f_bpres_dot + real(kind(0._wp)) :: T_bar + real(kind(0._wp)) :: grad_T + real(kind(0._wp)) :: tmp1, tmp2 + real(kind(0._wp)) :: f_bpres_dot if (thermal == 3) then T_bar = Tw*(fpb/pb0(iR0))*(fR/R0(iR0))**3 & *(mass_n0(iR0) + mass_v0(iR0))/(mass_n0(iR0) + fmass_v) grad_T = -Re_trans_T(iR0)*(T_bar - Tw) - f_bpres_dot = 3.d0*gamma_m*(-fV*fpb + fvflux*R_v*Tw & - + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR + f_bpres_dot = 3._wp*gamma_m*(-fV*fpb + fvflux*R_v*Tw & + + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR else - f_bpres_dot = -3.d0*gamma_m*fV/fR*(fpb - pv) + f_bpres_dot = -3._wp*gamma_m*fV/fR*(fpb - pv) end if end function f_bpres_dot diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 5b95b6d92f..03c6a89d00 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -40,14 +40,14 @@ module m_cbc !! q_prim_vf in the coordinate direction normal to the domain boundary along !! which the CBC is applied. #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), q_prim_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), q_prim_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), q_prim_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), q_prim_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), q_prim_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), q_prim_rsz_vf) !$acc declare link(q_prim_rsx_vf, q_prim_rsy_vf, q_prim_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: q_prim_rsx_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: q_prim_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: q_prim_rsz_vf + real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsz_vf #endif #ifdef CRAY_ACC_WAR @@ -60,65 +60,65 @@ module m_cbc !! cell-average primitive variables, q_prims_rs_vf, and not a Riemann solver. #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), F_rsx_vf, F_src_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), F_rsy_vf, F_src_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), F_rsz_vf, F_src_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), F_rsx_vf, F_src_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), F_rsy_vf, F_src_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), F_rsz_vf, F_src_rsz_vf) !$acc declare link(F_rsx_vf, F_src_rsx_vf, F_rsy_vf, F_src_rsy_vf, F_rsz_vf, F_src_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: F_rsx_vf, F_src_rsx_vf !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: F_rsy_vf, F_src_rsy_vf !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: F_rsz_vf, F_src_rsz_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: F_rsx_vf, F_src_rsx_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: F_rsy_vf, F_src_rsy_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: F_rsz_vf, F_src_rsz_vf !< #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsx_vf, flux_src_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsy_vf, flux_src_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsz_vf, flux_src_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsx_vf, flux_src_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsy_vf, flux_src_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsz_vf, flux_src_rsz_vf) !$acc declare link(flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf #endif - real(kind(0d0)) :: c !< Cell averaged speed of sound - real(kind(0d0)), dimension(2) :: Re !< Cell averaged Reynolds numbers + real(wp) :: c !< Cell averaged speed of sound + real(wp), dimension(2) :: Re !< Cell averaged Reynolds numbers !$acc declare create(c, Re) - real(kind(0d0)) :: dpres_ds !< Spatial derivatives in s-dir of pressure + real(wp) :: dpres_ds !< Spatial derivatives in s-dir of pressure !$acc declare create(dpres_ds) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), ds) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), ds) !$acc declare link(ds) #else - real(kind(0d0)), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction + real(wp), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction #endif ! CBC Coefficients ========================================================= #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), fd_coef_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), fd_coef_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), fd_coef_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), fd_coef_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), fd_coef_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), fd_coef_z) !$acc declare link(fd_coef_x, fd_coef_y, fd_coef_z) #else - real(kind(0d0)), allocatable, dimension(:, :) :: fd_coef_x !< Finite diff. coefficients x-dir - real(kind(0d0)), allocatable, dimension(:, :) :: fd_coef_y !< Finite diff. coefficients y-dir - real(kind(0d0)), allocatable, dimension(:, :) :: fd_coef_z !< Finite diff. coefficients z-dir + real(wp), allocatable, dimension(:, :) :: fd_coef_x !< Finite diff. coefficients x-dir + real(wp), allocatable, dimension(:, :) :: fd_coef_y !< Finite diff. coefficients y-dir + real(wp), allocatable, dimension(:, :) :: fd_coef_z !< Finite diff. coefficients z-dir #endif !! The first dimension identifies the location of a coefficient in the FD !! formula, while the last dimension denotes the location of the CBC. ! Bug with NVHPC when using nullified pointers in a declare create - ! real(kind(0d0)), pointer, dimension(:, :) :: fd_coef => null() + ! real(wp), pointer, dimension(:, :) :: fd_coef => null() #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), pi_coef_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), pi_coef_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), pi_coef_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), pi_coef_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), pi_coef_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), pi_coef_z) !$acc declare link(pi_coef_x, pi_coef_y, pi_coef_z) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir - real(kind(0d0)), allocatable, dimension(:, :, :) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir - real(kind(0d0)), allocatable, dimension(:, :, :) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir + real(wp), allocatable, dimension(:, :, :) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir + real(wp), allocatable, dimension(:, :, :) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir + real(wp), allocatable, dimension(:, :, :) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir #endif !! The first dimension of the array identifies the polynomial, the !! second dimension identifies the position of its coefficients and the last @@ -440,7 +440,7 @@ contains integer, intent(in) :: cbc_dir_in, cbc_loc_in ! Cell-boundary locations in the s-direction - real(kind(0d0)), dimension(0:buff_size + 1) :: s_cb + real(wp), dimension(0:buff_size + 1) :: s_cb ! Generic loop iterator integer :: i @@ -449,7 +449,7 @@ contains call s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) ! Determining the cell-boundary locations in the s-direction - s_cb(0) = 0d0 + s_cb(0) = 0._wp do i = 0, buff_size s_cb(i + 1) = s_cb(i) + ds(i) @@ -460,8 +460,8 @@ contains if (cbc_dir_in == ${CBC_DIR}$) then if (weno_order == 1) then - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$ (0, cbc_loc_in) = -2d0/(ds(0) + ds(1)) + 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) ! ================================================================== @@ -469,10 +469,10 @@ contains ! Computing CBC2 Coefficients ====================================== elseif (weno_order == 3) then - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$ (0, cbc_loc_in) = -6d0/(3d0*ds(0) + 2d0*ds(1) - ds(2)) - fd_coef_${XYZ}$ (1, cbc_loc_in) = -4d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/3d0 - fd_coef_${XYZ}$ (2, cbc_loc_in) = fd_coef_${XYZ}$ (0, cbc_loc_in)/3d0 + 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 pi_coef_${XYZ}$ (0, 0, cbc_loc_in) = (s_cb(0) - s_cb(1))/(s_cb(0) - s_cb(2)) @@ -481,14 +481,14 @@ contains ! Computing CBC4 Coefficients ====================================== else - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0d0 - fd_coef_${XYZ}$ (0, cbc_loc_in) = -50d0/(25d0*ds(0) + 2d0*ds(1) & - - 1d1*ds(2) + 1d1*ds(3) & - - 3d0*ds(4)) - fd_coef_${XYZ}$ (1, cbc_loc_in) = -48d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$ (2, cbc_loc_in) = 36d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$ (3, cbc_loc_in) = -16d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 - fd_coef_${XYZ}$ (4, cbc_loc_in) = 3d0*fd_coef_${XYZ}$ (0, cbc_loc_in)/25d0 + 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) & + - 1d1*ds(2) + 1d1*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))* & @@ -632,35 +632,35 @@ contains ! First-order time derivatives of the partial densities, density, ! velocity, pressure, advection variables, and the specific heat ! ratio and liquid stiffness functions - real(kind(0d0)), dimension(num_fluids) :: dalpha_rho_dt - real(kind(0d0)) :: drho_dt - real(kind(0d0)), dimension(num_dims) :: dvel_dt - real(kind(0d0)) :: dpres_dt - real(kind(0d0)), dimension(num_fluids) :: dadv_dt - real(kind(0d0)) :: dgamma_dt - real(kind(0d0)) :: dpi_inf_dt - real(kind(0d0)) :: dqv_dt - real(kind(0d0)), dimension(contxe) :: alpha_rho, dalpha_rho_ds, mf - real(kind(0d0)), dimension(2) :: Re_cbc - real(kind(0d0)), dimension(num_dims) :: vel, dvel_ds - real(kind(0d0)), dimension(num_fluids) :: adv, dadv_ds - real(kind(0d0)), dimension(sys_size) :: L - real(kind(0d0)), dimension(3) :: lambda - - real(kind(0d0)) :: rho !< Cell averaged density - real(kind(0d0)) :: pres !< Cell averaged pressure - real(kind(0d0)) :: E !< Cell averaged energy - real(kind(0d0)) :: H !< Cell averaged enthalpy - real(kind(0d0)) :: gamma !< Cell averaged specific heat ratio - real(kind(0d0)) :: pi_inf !< Cell averaged liquid stiffness - real(kind(0d0)) :: qv !< Cell averaged fluid reference energy - real(kind(0d0)) :: c - - real(kind(0d0)) :: vel_K_sum, vel_dv_dt_sum + real(wp), dimension(num_fluids) :: dalpha_rho_dt + real(wp) :: drho_dt + real(wp), dimension(num_dims) :: dvel_dt + real(wp) :: dpres_dt + real(wp), dimension(num_fluids) :: dadv_dt + real(wp) :: dgamma_dt + real(wp) :: dpi_inf_dt + real(wp) :: dqv_dt + real(wp), dimension(contxe) :: alpha_rho, dalpha_rho_ds, mf + real(wp), dimension(2) :: Re_cbc + real(wp), dimension(num_dims) :: vel, dvel_ds + real(wp), dimension(num_fluids) :: adv, dadv_ds + real(wp), dimension(sys_size) :: L + 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) :: vel_K_sum, vel_dv_dt_sum integer :: i, j, k, r, q !< Generic loop iterators - real(kind(0d0)) :: blkmod1, blkmod2 !< Fluid bulk modulus for Wood mixture sound speed + real(wp) :: blkmod1, blkmod2 !< Fluid bulk modulus for Wood mixture sound speed ! Reshaping of inputted data and association of the FD and PI ! coefficients, or CBC coefficients, respectively, hinging on @@ -778,10 +778,10 @@ contains vel(i) = q_prim_rs${XYZ}$_vf(0, k, r, contxe + i) end do - vel_K_sum = 0d0 + vel_K_sum = 0._wp !$acc loop seq do i = 1, num_dims - vel_K_sum = vel_K_sum + vel(i)**2d0 + vel_K_sum = vel_K_sum + vel(i)**2._wp end do pres = q_prim_rs${XYZ}$_vf(0, k, r, E_idx) @@ -814,18 +814,18 @@ contains !$acc loop seq do i = 1, contxe - dalpha_rho_ds(i) = 0d0 + dalpha_rho_ds(i) = 0._wp end do !$acc loop seq do i = 1, num_dims - dvel_ds(i) = 0d0 + dvel_ds(i) = 0._wp end do - dpres_ds = 0d0 + dpres_ds = 0._wp !$acc loop seq do i = 1, advxe - E_idx - dadv_ds(i) = 0d0 + dadv_ds(i) = 0._wp end do !$acc loop seq @@ -896,12 +896,12 @@ contains !$acc loop seq do i = 1, num_dims dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))* & - (L(1) - L(advxe))/(2d0*rho*c) + & - (dir_flg(dir_idx(i)) - 1d0)* & + (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 = 0d0 + vel_dv_dt_sum = 0._wp !$acc loop seq do i = 1, num_dims vel_dv_dt_sum = vel_dv_dt_sum + vel(i)*dvel_dt(i) @@ -920,7 +920,7 @@ contains end do end if - drho_dt = 0d0; dgamma_dt = 0d0; dpi_inf_dt = 0d0; dqv_dt = 0d0 + drho_dt = 0._wp; dgamma_dt = 0._wp; dpi_inf_dt = 0._wp; dqv_dt = 0._wp if (model_eqns == 1) then drho_dt = dalpha_rho_dt(1) @@ -962,14 +962,14 @@ contains if (riemann_solver == 1) then !$acc loop seq do i = advxb, advxe - flux_rs${XYZ}$_vf(-1, k, r, i) = 0d0 + flux_rs${XYZ}$_vf(-1, k, r, i) = 0._wp end do !$acc loop seq do i = advxb, advxe flux_src_rs${XYZ}$_vf(-1, k, r, i) = & - 1d0/max(abs(vel(dir_idx(1))), sgm_eps) & - *sign(1d0, vel(dir_idx(1))) & + 1._wp/max(abs(vel(dir_idx(1))), sgm_eps) & + *sign(1._wp, vel(dir_idx(1))) & *(flux_rs${XYZ}$_vf(0, k, r, i) & + vel(dir_idx(1)) & *flux_src_rs${XYZ}$_vf(0, k, r, i) & @@ -1039,13 +1039,13 @@ contains if (cbc_dir == 1) then is1%beg = 0; is1%end = buff_size; is2 = iy; is3 = iz - dir_idx = (/1, 2, 3/); dir_flg = (/1d0, 0d0, 0d0/) + dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) elseif (cbc_dir == 2) then is1%beg = 0; is1%end = buff_size; is2 = ix; is3 = iz - dir_idx = (/2, 1, 3/); dir_flg = (/0d0, 1d0, 0d0/) + dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) else is1%beg = 0; is1%end = buff_size; is2 = iy; is3 = ix - dir_idx = (/3, 1, 2/); dir_flg = (/0d0, 0d0, 1d0/) + dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) end if dj = max(0, cbc_loc) @@ -1073,7 +1073,7 @@ contains 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(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1085,7 +1085,7 @@ contains do j = -1, buff_size flux_rsx_vf(j, k, r, i) = & flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1120,7 +1120,7 @@ contains do j = -1, buff_size flux_src_rsx_vf(j, k, r, advxb) = & flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1149,7 +1149,7 @@ contains 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(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1161,7 +1161,7 @@ contains do j = -1, buff_size flux_rsy_vf(j, k, r, i) = & flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1196,7 +1196,7 @@ contains do j = -1, buff_size flux_src_rsy_vf(j, k, r, advxb) = & flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1225,7 +1225,7 @@ contains 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(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1237,7 +1237,7 @@ contains do j = -1, buff_size flux_rsz_vf(j, k, r, i) = & flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1272,7 +1272,7 @@ contains do j = -1, buff_size flux_src_rsz_vf(j, k, r, advxb) = & flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1322,7 +1322,7 @@ contains do j = -1, buff_size flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) = & flux_rsx_vf(j, k, r, i)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1356,7 +1356,7 @@ contains do j = -1, buff_size flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = & flux_src_rsx_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1373,7 +1373,7 @@ contains do j = -1, buff_size flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) = & flux_rsy_vf(j, k, r, i)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1408,7 +1408,7 @@ contains do j = -1, buff_size flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = & flux_src_rsy_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1426,7 +1426,7 @@ contains do j = -1, buff_size flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) = & flux_rsz_vf(j, k, r, i)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do @@ -1461,7 +1461,7 @@ contains do j = -1, buff_size flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = & flux_src_rsz_vf(j, k, r, advxb)* & - sign(1d0, -real(cbc_loc, kind(0d0))) + sign(1._wp, -real(cbc_loc, wp)) end do end do end do diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 0a65ecd4e8..115f477b7d 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -65,9 +65,9 @@ contains "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) @:PROHIBIT(weno_order /= 1 .and. f_is_default(weno_eps), & "weno_order != 1, but weno_eps is not set. A typical value of weno_eps is 1e-6") - @:PROHIBIT(weno_eps <= 0d0, "weno_eps must be positive. A typical value of weno_eps is 1e-6") + @:PROHIBIT(weno_eps <= 0._wp, "weno_eps must be positive. A typical value of weno_eps is 1e-6") @:PROHIBIT(teno .and. f_is_default(teno_CT), "teno is used, but teno_CT is not set. A typical value of teno_CT is 1e-6") - @:PROHIBIT(teno .and. teno_CT <= 0d0, "teno_CT must be positive. A typical value of teno_CT is 1e-6") + @:PROHIBIT(teno .and. teno_CT <= 0._wp, "teno_CT must be positive. A typical value of teno_CT is 1e-6") @:PROHIBIT(count([mapped_weno, wenoz, teno]) >= 2, "Only one of mapped_weno, wenoz, or teno can be set to true") @:PROHIBIT(weno_order == 1 .and. mapped_weno) @:PROHIBIT(weno_order == 1 .and. wenoz) @@ -180,7 +180,7 @@ contains "acoustic("//trim(jStr)//")%dipole is not supported for support >= 5 (non-planar supports)") @:PROHIBIT(acoustic(j)%support < 5 .and. f_is_default(acoustic(j)%dir), & "acoustic("//trim(jStr)//")%dir must be specified for support < 5 (planer support)") - @:PROHIBIT(acoustic(j)%support == 1 .and. f_approx_equal(acoustic(j)%dir, 0d0), & + @:PROHIBIT(acoustic(j)%support == 1 .and. f_approx_equal(acoustic(j)%dir, 0._wp), & "acoustic("//trim(jStr)//")dir must be non-zero for support = 1") @:PROHIBIT(acoustic(j)%pulse == 2 .and. f_is_default(acoustic(j)%delay), & "acoustic("//trim(jStr)//")%delay must be specified for pulse = 2 (Gaussian)") @@ -189,20 +189,20 @@ contains @:PROHIBIT((acoustic(j)%support == 2 .or. acoustic(j)%support == 3) .and. f_is_default(acoustic(j)%length), & "acoustic("//trim(jStr)//")%length must be specified for support = 2 or 3") - @:PROHIBIT((acoustic(j)%support == 2 .or. acoustic(j)%support == 3) .and. acoustic(j)%length <= 0d0, & + @:PROHIBIT((acoustic(j)%support == 2 .or. acoustic(j)%support == 3) .and. acoustic(j)%length <= 0._wp, & "acoustic("//trim(jStr)//")%length must be positive for support = 2 or 3") @:PROHIBIT(acoustic(j)%support == 3 .and. f_is_default(acoustic(j)%height), & "acoustic("//trim(jStr)//")%height must be specified for support = 3") - @:PROHIBIT(acoustic(j)%support == 3 .and. acoustic(j)%height <= 0d0, & + @:PROHIBIT(acoustic(j)%support == 3 .and. acoustic(j)%height <= 0._wp, & "acoustic("//trim(jStr)//")%height must be positive for support = 3") @:PROHIBIT(acoustic(j)%support >= 5 .and. f_is_default(acoustic(j)%foc_length), & "acoustic("//trim(jStr)//")%foc_length must be specified for support >= 5 (non-planar supports)") - @:PROHIBIT(acoustic(j)%support >= 5 .and. acoustic(j)%foc_length <= 0d0, & + @:PROHIBIT(acoustic(j)%support >= 5 .and. acoustic(j)%foc_length <= 0._wp, & "acoustic("//trim(jStr)//")%foc_length must be positive for support >= 5 (non-planar supports)") @:PROHIBIT(acoustic(j)%support >= 5 .and. f_is_default(acoustic(j)%aperture), & "acoustic("//trim(jStr)//")%aperture must be specified for support >= 5 (non-planar supports)") - @:PROHIBIT(acoustic(j)%support >= 5 .and. acoustic(j)%aperture <= 0d0, & + @:PROHIBIT(acoustic(j)%support >= 5 .and. acoustic(j)%aperture <= 0._wp, & "acoustic("//trim(jStr)//")%aperture must be positive for support >= 5 (non-planar supports)") @:PROHIBIT(any(acoustic(j)%support == (/9, 10, 11/)) .and. acoustic(j)%num_elements == dflt_int, & @@ -215,11 +215,11 @@ contains "acoustic("//trim(jStr)//")%element_on must be less than or equal to num_elements for support = 9, 10, or 11 (transducer array)") @:PROHIBIT(any(acoustic(j)%support == (/9, 10/)) .and. f_is_default(acoustic(j)%element_spacing_angle), & "acoustic("//trim(jStr)//")%element_spacing_angle must be specified for support = 9 or 10 (2D transducer array)") - @:PROHIBIT(any(acoustic(j)%support == (/9, 10/)) .and. acoustic(j)%element_spacing_angle < 0d0, & + @:PROHIBIT(any(acoustic(j)%support == (/9, 10/)) .and. acoustic(j)%element_spacing_angle < 0._wp, & "acoustic("//trim(jStr)//")%element_spacing_angle must be non-negative for support = 9 or 10 (2D transducer array)") @:PROHIBIT(acoustic(j)%support == 11 .and. f_is_default(acoustic(j)%element_polygon_ratio), & "acoustic("//trim(jStr)//")%element_polygon_ratio must be specified for support = 11 (3D transducer array)") - @:PROHIBIT(acoustic(j)%support == 11 .and. acoustic(j)%element_polygon_ratio <= 0d0, & + @:PROHIBIT(acoustic(j)%support == 11 .and. acoustic(j)%element_polygon_ratio <= 0._wp, & "acoustic("//trim(jStr)//")%element_polygon_ratio must be positive for support = 11 (3D transducer array)") end do @@ -262,7 +262,7 @@ contains do i = 1, num_fluids do j = 1, 2 call s_int_to_str(j, jStr) - @:PROHIBIT((.not. f_is_default(fluid_pp(i)%Re(j))) .and. fluid_pp(i)%Re(j) <= 0d0, & + @:PROHIBIT((.not. f_is_default(fluid_pp(i)%Re(j))) .and. fluid_pp(i)%Re(j) <= 0._wp, & "fluid_pp("//trim(iStr)//")%"// "Re("//trim(jStr)//") must be positive.") @:PROHIBIT(model_eqns == 1 .and. (.not. f_is_default(fluid_pp(i)%Re(j))), & "model_eqns = 1 does not support fluid_pp("//trim(iStr)//")%"// "Re("//trim(jStr)//")") diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index c4b369945e..e061e4e07f 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -33,20 +33,20 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i L(1) = lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) do i = 2, advxe - L(i) = 0d0 + L(i) = 0._wp end do L(advxe) = L(1) @@ -63,35 +63,35 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i !< Generic loop iterator - L(1) = (5d-1 - 5d-1*sign(1d0, lambda(1)))*lambda(1) & + L(1) = (5d-1 - 5d-1*sign(1._wp, lambda(1)))*lambda(1) & *(dpres_ds - rho*c*dvel_ds(dir_idx(1))) do i = 2, momxb - L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & + L(i) = (5d-1 - 5d-1*sign(1._wp, lambda(2)))*lambda(2) & *(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) end do do i = momxb + 1, momxe - L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & + L(i) = (5d-1 - 5d-1*sign(1._wp, lambda(2)))*lambda(2) & *(dvel_ds(dir_idx(i - contxe))) end do do i = E_idx, advxe - 1 - L(i) = (5d-1 - 5d-1*sign(1d0, lambda(2)))*lambda(2) & + L(i) = (5d-1 - 5d-1*sign(1._wp, lambda(2)))*lambda(2) & *(dadv_ds(i - momxe)) end do - L(advxe) = (5d-1 - 5d-1*sign(1d0, lambda(3)))*lambda(3) & + L(advxe) = (5d-1 - 5d-1*sign(1._wp, lambda(3)))*lambda(3) & *(dpres_ds + rho*c*dvel_ds(dir_idx(1))) end subroutine s_compute_nonreflecting_subsonic_buffer_L @@ -105,20 +105,20 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i L(1) = lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) do i = 2, advxe - L(i) = 0d0 + L(i) = 0._wp end do end subroutine s_compute_nonreflecting_subsonic_inflow_L @@ -133,13 +133,13 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i !> Generic loop iterator @@ -158,7 +158,7 @@ contains end do ! bubble index - L(advxe) = 0d0 + L(advxe) = 0._wp end subroutine s_compute_nonreflecting_subsonic_outflow_L @@ -175,13 +175,13 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i !> Generic loop iterator @@ -199,7 +199,7 @@ contains L(i) = lambda(2)*(dadv_ds(i - momxe)) end do - L(advxe) = L(1) + 2d0*rho*c*lambda(2)*dvel_ds(dir_idx(1)) + L(advxe) = L(1) + 2._wp*rho*c*lambda(2)*dvel_ds(dir_idx(1)) end subroutine s_compute_force_free_subsonic_outflow_L @@ -213,13 +213,13 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i !> Generic loop iterator @@ -252,17 +252,17 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i do i = 1, advxe - L(i) = 0d0 + L(i) = 0._wp end do end subroutine s_compute_supersonic_inflow_L @@ -277,13 +277,13 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(3), intent(in) :: lambda - real(kind(0d0)), dimension(sys_size), intent(inout) :: L - real(kind(0d0)), intent(in) :: rho, c - real(kind(0d0)), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(kind(0d0)), intent(in) :: dpres_ds - real(kind(0d0)), dimension(num_dims), intent(in) :: dvel_ds - real(kind(0d0)), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: lambda + real(wp), dimension(sys_size), intent(inout) :: L + real(wp), intent(in) :: rho, c + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), intent(in) :: dpres_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds integer :: i !< Generic loop iterator diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 60bf389761..38208e3de0 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -26,9 +26,9 @@ module m_compute_levelset s_compute_rectangle_levelset, & s_compute_sphere_levelset - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid - real(kind(0d0)) :: length_x, length_y, length_z - real(kind(0d0)) :: radius + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z + real(wp) :: radius type(bounds_info) :: x_boundary, y_boundary, z_boundary !< !! These variables combine the centroid and length parameters associated with @@ -41,13 +41,13 @@ contains !> Initialize IBM module subroutine s_compute_circle_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: radius, dist - real(kind(0d0)) :: x_centroid, y_centroid - real(kind(0d0)), dimension(3) :: dist_vec + real(wp) :: radius, dist + real(wp) :: x_centroid, y_centroid + real(wp), dimension(3) :: dist_vec integer :: i, j !< Loop index variables @@ -77,20 +77,20 @@ contains subroutine s_compute_airfoil_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: radius, dist, global_dist + real(wp) :: radius, dist, global_dist integer :: global_id - real(kind(0d0)) :: x_centroid, y_centroid, x_act, y_act, theta - real(kind(0d0)), dimension(3) :: dist_vec + real(wp) :: x_centroid, y_centroid, x_act, y_act, theta + real(wp), dimension(3) :: dist_vec integer :: i, j, k !< Loop index variables x_centroid = patch_ib(ib_patch_id)%x_centroid y_centroid = patch_ib(ib_patch_id)%y_centroid - theta = pi*patch_ib(ib_patch_id)%theta/180d0 + theta = pi*patch_ib(ib_patch_id)%theta/180._wp do i = 0, m do j = 0, n @@ -160,14 +160,14 @@ contains subroutine s_compute_3D_airfoil_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: radius, dist, dist_surf, dist_side, global_dist + real(wp) :: radius, dist, dist_surf, dist_side, global_dist integer :: global_id - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid, lz, z_max, z_min, x_act, y_act, theta - real(kind(0d0)), dimension(3) :: dist_vec + real(wp) :: x_centroid, y_centroid, z_centroid, lz, z_max, z_min, x_act, y_act, theta + real(wp), dimension(3) :: dist_vec integer :: i, j, k, l !< Loop index variables @@ -175,7 +175,7 @@ contains y_centroid = patch_ib(ib_patch_id)%y_centroid z_centroid = patch_ib(ib_patch_id)%z_centroid lz = patch_ib(ib_patch_id)%length_z - theta = pi*patch_ib(ib_patch_id)%theta/180d0 + theta = pi*patch_ib(ib_patch_id)%theta/180._wp z_max = z_centroid + lz/2 z_min = z_centroid - lz/2 @@ -262,13 +262,13 @@ contains !> Initialize IBM module subroutine s_compute_rectangle_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: top_right(2), bottom_left(2) - real(kind(0d0)) :: x, y, min_dist - real(kind(0d0)) :: side_dists(4) + real(wp) :: top_right(2), bottom_left(2) + real(wp) :: x, y, min_dist + real(wp) :: side_dists(4) integer :: i, j, k !< Loop index variables @@ -305,7 +305,7 @@ contains if (min_dist == abs(side_dists(1))) then levelset(i, j, 0, ib_patch_id) = side_dists(1) if (side_dists(1) == 0) then - levelset_norm(i, j, 0, ib_patch_id, 1) = 0d0 + levelset_norm(i, j, 0, ib_patch_id, 1) = 0._wp else levelset_norm(i, j, 0, ib_patch_id, 1) = side_dists(1)/ & abs(side_dists(1)) @@ -314,7 +314,7 @@ contains else if (min_dist == abs(side_dists(2))) then levelset(i, j, 0, ib_patch_id) = side_dists(2) if (side_dists(2) == 0) then - levelset_norm(i, j, 0, ib_patch_id, 1) = 0d0 + levelset_norm(i, j, 0, ib_patch_id, 1) = 0._wp else levelset_norm(i, j, 0, ib_patch_id, 1) = side_dists(2)/ & abs(side_dists(2)) @@ -322,7 +322,7 @@ contains else if (min_dist == abs(side_dists(3))) then if (side_dists(3) == 0) then - levelset_norm(i, j, 0, ib_patch_id, 1) = 0d0 + levelset_norm(i, j, 0, ib_patch_id, 1) = 0._wp else levelset_norm(i, j, 0, ib_patch_id, 1) = side_dists(3)/ & abs(side_dists(3)) @@ -330,7 +330,7 @@ contains else if (min_dist == abs(side_dists(4))) then if (side_dists(4) == 0) then - levelset_norm(i, j, 0, ib_patch_id, 1) = 0d0 + levelset_norm(i, j, 0, ib_patch_id, 1) = 0._wp else levelset_norm(i, j, 0, ib_patch_id, 1) = side_dists(4)/ & abs(side_dists(4)) @@ -347,13 +347,13 @@ contains subroutine s_compute_sphere_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: radius, dist - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid - real(kind(0d0)), dimension(3) :: dist_vec + real(wp) :: radius, dist + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp), dimension(3) :: dist_vec integer :: i, j, k !< Loop index variables @@ -384,15 +384,15 @@ contains subroutine s_compute_cylinder_levelset(levelset, levelset_norm, ib_patch_id) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer, intent(in) :: ib_patch_id - real(kind(0d0)) :: radius, dist - real(kind(0d0)) :: x_centroid, y_centroid, z_centroid - real(kind(0d0)) :: length_x, length_y, length_z - real(kind(0d0)), dimension(3) :: pos_vec, centroid_vec, dist_vec, dist_sides_vec, dist_surface_vec - real(kind(0d0)) :: dist_side, dist_surface, side_pos + real(wp) :: radius, dist + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z + real(wp), dimension(3) :: pos_vec, centroid_vec, dist_vec, dist_sides_vec, dist_surface_vec + real(wp) :: dist_side, dist_surface, side_pos type(bounds_info) :: boundary integer :: i, j, k !< Loop index variables @@ -404,17 +404,17 @@ contains length_y = patch_ib(ib_patch_id)%length_y length_z = patch_ib(ib_patch_id)%length_z - if (length_x /= 0d0) then + if (length_x /= 0._wp) then boundary%beg = x_centroid - 0.5*length_x boundary%end = x_centroid + 0.5*length_x dist_sides_vec = (/1, 0, 0/) dist_surface_vec = (/0, 1, 1/) - else if (length_y /= 0d0) then + else if (length_y /= 0._wp) then boundary%beg = y_centroid - 0.5*length_y boundary%end = y_centroid + 0.5*length_y dist_sides_vec = (/0, 1, 0/) dist_surface_vec = (/1, 0, 1/) - else if (length_z /= 0d0) then + else if (length_z /= 0._wp) then boundary%beg = z_centroid - 0.5*length_z boundary%end = z_centroid + 0.5*length_z dist_sides_vec = (/0, 0, 1/) diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index b5d33da119..7f825f694d 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -71,31 +71,31 @@ module m_data_output end subroutine s_write_abstract_data_files end interface ! ======================================================== #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), icfl_sf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), vcfl_sf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), ccfl_sf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), Rc_sf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), icfl_sf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), vcfl_sf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), ccfl_sf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), Rc_sf) !$acc declare link(icfl_sf, vcfl_sf, ccfl_sf, Rc_sf) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: icfl_sf !< ICFL stability criterion - real(kind(0d0)), allocatable, dimension(:, :, :) :: vcfl_sf !< VCFL stability criterion - real(kind(0d0)), allocatable, dimension(:, :, :) :: ccfl_sf !< CCFL stability criterion - real(kind(0d0)), allocatable, dimension(:, :, :) :: Rc_sf !< Rc stability criterion + real(wp), allocatable, dimension(:, :, :) :: icfl_sf !< ICFL stability criterion + real(wp), allocatable, dimension(:, :, :) :: vcfl_sf !< VCFL stability criterion + real(wp), allocatable, dimension(:, :, :) :: ccfl_sf !< CCFL stability criterion + real(wp), allocatable, dimension(:, :, :) :: Rc_sf !< Rc stability criterion !$acc declare create(icfl_sf, vcfl_sf, ccfl_sf, Rc_sf) #endif - real(kind(0d0)) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids - real(kind(0d0)) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids - real(kind(0d0)) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids - real(kind(0d0)) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids + real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids + real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids + real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids + real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids !$acc declare create(icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb, 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(kind(0d0)) :: icfl_max !< ICFL criterion maximum - real(kind(0d0)) :: vcfl_max !< VCFL criterion maximum - real(kind(0d0)) :: ccfl_max !< CCFL criterion maximum - real(kind(0d0)) :: 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 !> @} procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() @@ -228,31 +228,31 @@ contains type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf integer, intent(IN) :: t_step - real(kind(0d0)), dimension(num_fluids) :: alpha_rho !< Cell-avg. partial density - real(kind(0d0)) :: rho !< Cell-avg. density - real(kind(0d0)), dimension(num_dims) :: vel !< Cell-avg. velocity - real(kind(0d0)) :: vel_sum !< Cell-avg. velocity sum - real(kind(0d0)) :: pres !< Cell-avg. pressure - real(kind(0d0)), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction - real(kind(0d0)) :: gamma !< Cell-avg. sp. heat ratio - real(kind(0d0)) :: pi_inf !< Cell-avg. liquid stiffness function - real(kind(0d0)) :: qv !< Cell-avg. fluid reference energy - real(kind(0d0)) :: c !< Cell-avg. sound speed - real(kind(0d0)) :: E !< Cell-avg. energy - real(kind(0d0)) :: H !< Cell-avg. enthalpy - real(kind(0d0)), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp), dimension(num_fluids) :: alpha_rho !< Cell-avg. partial density + real(wp) :: rho !< Cell-avg. density + real(wp), dimension(num_dims) :: vel !< Cell-avg. velocity + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + 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) :: E !< Cell-avg. energy + real(wp) :: H !< Cell-avg. enthalpy + real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers ! ICFL, VCFL, CCFL and Rc stability criteria extrema for the current ! time-step and located on both the local (loc) and the global (glb) ! computational domains - real(kind(0d0)) :: blkmod1, blkmod2 !< + real(wp) :: blkmod1, blkmod2 !< !! Fluid bulk modulus for Woods mixture sound speed integer :: i, j, k, l, q !< Generic loop iterators integer :: Nfq - real(kind(0d0)) :: fltr_dtheta !< + real(wp) :: fltr_dtheta !< !! Modified dtheta accounting for Fourier filtering in azimuthal direction. ! Computing Stability Criteria at Current Time-step ================ @@ -343,7 +343,7 @@ contains if (icfl_max_glb /= icfl_max_glb) then call s_mpi_abort('ICFL is NaN. Exiting ...') - elseif (icfl_max_glb > 1d0) then + elseif (icfl_max_glb > 1._wp) then print *, 'icfl', icfl_max_glb call s_mpi_abort('ICFL is greater than 1.0. Exiting ...') end if @@ -355,7 +355,7 @@ contains if (vcfl_max_glb /= vcfl_max_glb) then call s_mpi_abort('VCFL is NaN. Exiting ...') - elseif (vcfl_max_glb > 1d0) then + elseif (vcfl_max_glb > 1._wp) then print *, 'vcfl', vcfl_max_glb call s_mpi_abort('VCFL is greater than 1.0. Exiting ...') end if @@ -389,12 +389,12 @@ contains integer :: i, j, k, l, ii, r!< Generic loop iterators - real(kind(0d0)), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(kind(0d0)) :: nbub, nR3, vftmp !< Temporary bubble number density - real(kind(0d0)) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(kind(0d0)) :: rho !< Temporary density - real(kind(0d0)), dimension(2) :: Re !< Temporary Reynolds number - real(kind(0d0)) :: E_e !< Temp. elastic energy contribution + real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration + real(wp) :: nbub, nR3, vftmp !< Temporary bubble number density + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + real(wp) :: rho !< Temporary density + real(wp), dimension(2) :: Re !< Temporary Reynolds number + real(wp) :: E_e !< Temp. elastic energy contribution ! Creating or overwriting the time-step root directory write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/p_all' @@ -491,7 +491,7 @@ contains end if gamma = fluid_pp(1)%gamma - lit_gamma = 1d0/fluid_pp(1)%gamma + 1d0 + lit_gamma = 1._wp/fluid_pp(1)%gamma + 1._wp pi_inf = fluid_pp(1)%pi_inf qv = fluid_pp(1)%qv @@ -514,9 +514,9 @@ contains do i = 1, sys_size !$acc 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 (=1d0) + ! q_prim_vf(bubxb) stores the value of nb needed in riemann solvers, so replace with true primitive value (=1._wp) if (qbmm) then - q_prim_vf(bubxb)%sf = 1d0 + q_prim_vf(bubxb)%sf = 1._wp end if end if @@ -809,8 +809,8 @@ contains 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -820,7 +820,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do !Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then @@ -828,7 +828,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if else @@ -836,7 +836,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -866,8 +866,8 @@ contains 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -879,10 +879,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do !Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then @@ -892,10 +892,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if else @@ -905,10 +905,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -927,53 +927,53 @@ contains integer, intent(in) :: t_step type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(kind(0d0)), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag + real(wp), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag - real(kind(0d0)), dimension(-1:m) :: distx - real(kind(0d0)), dimension(-1:n) :: disty - real(kind(0d0)), dimension(-1:p) :: distz + 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(kind(0d0)) :: lit_gamma, nbub - real(kind(0d0)) :: rho - real(kind(0d0)), dimension(num_dims) :: vel - real(kind(0d0)) :: pres - real(kind(0d0)) :: ptilde - real(kind(0d0)) :: ptot - real(kind(0d0)) :: alf - real(kind(0d0)) :: alfgr - real(kind(0d0)), dimension(num_fluids) :: alpha - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf - real(kind(0d0)) :: qv - real(kind(0d0)) :: c - real(kind(0d0)) :: M00, M10, M01, M20, M11, M02 - real(kind(0d0)) :: varR, varV - real(kind(0d0)), dimension(Nb) :: nR, R, nRdot, Rdot - real(kind(0d0)) :: nR3 - real(kind(0d0)) :: accel - real(kind(0d0)) :: int_pres - real(kind(0d0)) :: max_pres - real(kind(0d0)), dimension(2) :: Re - real(kind(0d0)) :: E_e - real(kind(0d0)), dimension(6) :: tau_e - real(kind(0d0)) :: G - real(kind(0d0)) :: dyn_p + real(wp) :: lit_gamma, nbub + real(wp) :: rho + real(wp), dimension(num_dims) :: 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) :: E_e + real(wp), dimension(6) :: tau_e + real(wp) :: G + real(wp) :: dyn_p integer :: i, j, k, l, s, q, d !< Generic loop iterator - real(kind(0d0)) :: nondim_time !< Non-dimensional time + real(wp) :: nondim_time !< Non-dimensional time - real(kind(0d0)) :: tmp !< + real(wp) :: tmp !< !! Temporary variable to store quantity for mpi_allreduce - real(kind(0d0)) :: blkmod1, blkmod2 !< + real(wp) :: blkmod1, blkmod2 !< !! Fluid bulk modulus for Woods mixture sound speed integer :: npts !< Number of included integral points - real(kind(0d0)) :: rad, thickness !< For integral quantities + real(wp) :: rad, thickness !< For integral quantities logical :: trigger !< For integral quantities real(kind(0d0)) :: rhoYks(1:num_species) @@ -983,37 +983,37 @@ contains nondim_time = mytime else if (t_step_old /= dflt_int) then - nondim_time = real(t_step + t_step_old, kind(0d0))*dt + nondim_time = real(t_step + t_step_old, wp)*dt else - nondim_time = real(t_step, kind(0d0))*dt !*1.d-5/10.0761131451d0 + nondim_time = real(t_step, wp)*dt !*1.d-5/10.0761131451_wp end if end if do i = 1, num_probes ! Zeroing out flow variables for all processors - rho = 0d0 + rho = 0._wp do s = 1, num_dims - vel(s) = 0d0 + vel(s) = 0._wp end do - pres = 0d0 - gamma = 0d0 - pi_inf = 0d0 - qv = 0d0 - c = 0d0 - accel = 0d0 - nR = 0d0; R = 0d0 - nRdot = 0d0; Rdot = 0d0 - nbub = 0d0 - M00 = 0d0 - M10 = 0d0 - M01 = 0d0 - M20 = 0d0 - M11 = 0d0 - M02 = 0d0 - varR = 0d0; varV = 0d0 - alf = 0d0 + pres = 0._wp + gamma = 0._wp + pi_inf = 0._wp + qv = 0._wp + c = 0._wp + accel = 0._wp + nR = 0._wp; R = 0._wp + nRdot = 0._wp; Rdot = 0._wp + nbub = 0._wp + M00 = 0._wp + M10 = 0._wp + M01 = 0._wp + M20 = 0._wp + M11 = 0._wp + M02 = 0._wp + varR = 0._wp; varV = 0._wp + alf = 0._wp do s = 1, (num_dims*(num_dims + 1))/2 - tau_e(s) = 0d0 + tau_e(s) = 0._wp end do ! Find probe location in terms of indices on a @@ -1022,7 +1022,7 @@ contains 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) < 0d0) distx(s) = 1000d0 + 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 @@ -1048,7 +1048,7 @@ contains vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k, l)/rho end do - dyn_p = 0.5d0*rho*dot_product(vel, vel) + dyn_p = 0.5_wp*rho*dot_product(vel, vel) if (hypoelasticity) then call s_compute_pressure( & @@ -1065,7 +1065,7 @@ contains end if if (model_eqns == 4) then - lit_gamma = 1d0/fluid_pp(1)%gamma + 1d0 + lit_gamma = 1._wp/fluid_pp(1)%gamma + 1._wp else if (hypoelasticity) then tau_e(1) = q_cons_vf(stress_idx%end)%sf(j - 2, k, l)/rho end if @@ -1083,12 +1083,12 @@ contains if (adv_n) then nbub = q_cons_vf(n_idx)%sf(j - 2, k, l) else - nR3 = 0d0 + nR3 = 0._wp do s = 1, nb - nR3 = nR3 + weight(s)*(nR(s)**3d0) + nR3 = nR3 + weight(s)*(nR(s)**3._wp) end do - nbub = dsqrt((4.d0*pi/3.d0)*nR3/alf) + nbub = dsqrt((4._wp*pi/3._wp)*nR3/alf) end if #ifdef DEBUG print *, 'In probe, nbub: ', nbub @@ -1107,8 +1107,8 @@ contains M11 = M11/M00 M02 = M02/M00 - varR = M20 - M10**2d0 - varV = M02 - M01**2d0 + varR = M20 - M10**2._wp + varV = M02 - M01**2._wp end if R(:) = nR(:)/nbub Rdot(:) = nRdot(:)/nbub @@ -1119,7 +1119,7 @@ contains ! Compute mixture sound Speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, c) accel = accel_mag(j - 2, k, l) end if @@ -1134,11 +1134,11 @@ contains if ((probe(i)%y >= y_cb(-1)) .and. (probe(i)%y <= y_cb(n))) then do s = -1, m distx(s) = x_cb(s) - probe(i)%x - if (distx(s) < 0d0) distx(s) = 1000d0 + if (distx(s) < 0._wp) distx(s) = 1000._wp end do do s = -1, n disty(s) = y_cb(s) - probe(i)%y - if (disty(s) < 0d0) disty(s) = 1000d0 + if (disty(s) < 0._wp) disty(s) = 1000._wp end do j = minloc(distx, 1) k = minloc(disty, 1) @@ -1154,7 +1154,7 @@ contains vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l)/rho end do - dyn_p = 0.5d0*rho*dot_product(vel, vel) + dyn_p = 0.5_wp*rho*dot_product(vel, vel) if (hypoelasticity) then call s_compute_pressure( & @@ -1173,7 +1173,7 @@ contains end if if (model_eqns == 4) then - lit_gamma = 1d0/fluid_pp(1)%gamma + 1d0 + lit_gamma = 1._wp/fluid_pp(1)%gamma + 1._wp else if (hypoelasticity) then do s = 1, 3 tau_e(s) = q_cons_vf(s)%sf(j - 2, k - 2, l)/rho @@ -1190,12 +1190,12 @@ contains if (adv_n) then nbub = q_cons_vf(n_idx)%sf(j - 2, k - 2, l) else - nR3 = 0d0 + nR3 = 0._wp do s = 1, nb - nR3 = nR3 + weight(s)*(nR(s)**3d0) + nR3 = nR3 + weight(s)*(nR(s)**3._wp) end do - nbub = dsqrt((4.d0*pi/3.d0)*nR3/alf) + nbub = dsqrt((4._wp*pi/3._wp)*nR3/alf) end if R(:) = nR(:)/nbub @@ -1204,7 +1204,7 @@ contains ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, c) accel = accel_mag(j - 2, k - 2, l) end if @@ -1215,15 +1215,15 @@ contains if ((probe(i)%z >= z_cb(-1)) .and. (probe(i)%z <= z_cb(p))) then do s = -1, m distx(s) = x_cb(s) - probe(i)%x - if (distx(s) < 0d0) distx(s) = 1000d0 + if (distx(s) < 0._wp) distx(s) = 1000._wp end do do s = -1, n disty(s) = y_cb(s) - probe(i)%y - if (disty(s) < 0d0) disty(s) = 1000d0 + if (disty(s) < 0._wp) disty(s) = 1000._wp end do do s = -1, p distz(s) = z_cb(s) - probe(i)%z - if (distz(s) < 0d0) distz(s) = 1000d0 + if (distz(s) < 0._wp) distz(s) = 1000._wp end do j = minloc(distx, 1) k = minloc(disty, 1) @@ -1240,7 +1240,7 @@ contains vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l - 2)/rho end do - dyn_p = 0.5d0*rho*dot_product(vel, vel) + dyn_p = 0.5_wp*rho*dot_product(vel, vel) if (chemistry) then do d = 1, num_species @@ -1265,7 +1265,7 @@ contains ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1d0)*pres + pi_inf)/rho, alpha, 0d0, c) + ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, c) accel = accel_mag(j - 2, k - 2, l - 2) end if @@ -1432,20 +1432,20 @@ contains if (integral_wrt .and. bubbles) then if (n == 0) then ! 1D simulation do i = 1, num_integrals - int_pres = 0d0 - max_pres = 0d0 + int_pres = 0._wp + max_pres = 0._wp k = 0; l = 0 npts = 0 do j = 1, m - pres = 0d0 + pres = 0._wp do s = 1, num_dims - vel(s) = 0d0 + vel(s) = 0._wp end do - rho = 0d0 - pres = 0d0 - gamma = 0d0 - pi_inf = 0d0 - qv = 0d0 + rho = 0._wp + pres = 0._wp + gamma = 0._wp + pi_inf = 0._wp + qv = 0._wp if ((integral(i)%xmin <= x_cb(j)) .and. (integral(i)%xmax >= x_cb(j))) then npts = npts + 1 @@ -1457,14 +1457,14 @@ contains pres = ( & (q_cons_vf(E_idx)%sf(j, k, l) - & - 0.5d0*(q_cons_vf(mom_idx%beg)%sf(j, k, l)**2.d0)/rho)/ & - (1.d0 - q_cons_vf(alf_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.d0)**2.d0 + int_pres = int_pres + (pres - 1._wp)**2._wp end if end do - int_pres = dsqrt(int_pres/(1.d0*npts)) + int_pres = dsqrt(int_pres/(1._wp*npts)) if (num_procs > 1) then tmp = int_pres @@ -1487,8 +1487,8 @@ contains thickness = integral(1)%xmin do i = 1, num_integrals - int_pres = 0d0 - max_pres = 0d0 + int_pres = 0._wp + max_pres = 0._wp l = 0 npts = 0 do j = 1, m @@ -1496,28 +1496,28 @@ contains trigger = .false. if (i == 1) then !inner portion - if (dsqrt(x_cb(j)**2.d0 + y_cb(k)**2.d0) < (rad - 0.5d0*thickness)) & + if (dsqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) < (rad - 0.5_wp*thickness)) & trigger = .true. elseif (i == 2) then !net region - if (dsqrt(x_cb(j)**2.d0 + y_cb(k)**2.d0) > (rad - 0.5d0*thickness) .and. & - dsqrt(x_cb(j)**2.d0 + y_cb(k)**2.d0) < (rad + 0.5d0*thickness)) & + if (dsqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad - 0.5_wp*thickness) .and. & + dsqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) < (rad + 0.5_wp*thickness)) & trigger = .true. elseif (i == 3) then !everything else - if (dsqrt(x_cb(j)**2.d0 + y_cb(k)**2.d0) > (rad + 0.5d0*thickness)) & + if (dsqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad + 0.5_wp*thickness)) & trigger = .true. end if - pres = 0d0 + pres = 0._wp do s = 1, num_dims - vel(s) = 0d0 + vel(s) = 0._wp end do - rho = 0d0 - pres = 0d0 - gamma = 0d0 - pi_inf = 0d0 - qv = 0d0 + rho = 0._wp + pres = 0._wp + gamma = 0._wp + pi_inf = 0._wp + qv = 0._wp if (trigger) then npts = npts + 1 @@ -1529,21 +1529,21 @@ contains pres = ( & (q_cons_vf(E_idx)%sf(j, k, l) - & - 0.5d0*(q_cons_vf(mom_idx%beg)%sf(j, k, l)**2.d0)/rho)/ & - (1.d0 - q_cons_vf(alf_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.d0) - max_pres = max(max_pres, abs(pres - 1.d0)) + int_pres = int_pres + abs(pres - 1._wp) + max_pres = max(max_pres, abs(pres - 1._wp)) end if end do end do if (npts > 0) then - int_pres = int_pres/(1.d0*npts) + int_pres = int_pres/(1._wp*npts) else - int_pres = 0.d0 + int_pres = 0._wp end if if (num_procs > 1) then @@ -1573,7 +1573,7 @@ contains !! all of the time-steps and the simulation run-time. subroutine s_close_run_time_information_file - real(kind(0d0)) :: 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)') '----------------------------------------'// & '----------------------------------------' @@ -1615,13 +1615,13 @@ contains ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria @:ALLOCATE_GLOBAL(icfl_sf(0:m, 0:n, 0:p)) - icfl_max = 0d0 + icfl_max = 0._wp if (any(Re_size > 0)) then @:ALLOCATE_GLOBAL(vcfl_sf(0:m, 0:n, 0:p)) @:ALLOCATE_GLOBAL(Rc_sf (0:m, 0:n, 0:p)) - vcfl_max = 0d0 + vcfl_max = 0._wp Rc_min = 1d3 end if diff --git a/src/simulation/m_derived_variables.f90 b/src/simulation/m_derived_variables.f90 index 1c4e838a56..6e45fe59f0 100644 --- a/src/simulation/m_derived_variables.f90 +++ b/src/simulation/m_derived_variables.f90 @@ -39,15 +39,15 @@ module m_derived_variables !! active coordinate directions, the centered family of the finite-difference !! schemes is used. !> @{ - real(kind(0d0)), public, allocatable, dimension(:, :) :: fd_coeff_x - real(kind(0d0)), public, allocatable, dimension(:, :) :: fd_coeff_y - real(kind(0d0)), 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 !> @} ! @name Variables for computing acceleration !> @{ - real(kind(0d0)), public, allocatable, dimension(:, :, :) :: accel_mag - real(kind(0d0)), 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 !> @} contains @@ -148,12 +148,12 @@ subroutine s_compute_derived_variables(t_step) do j = 0, n do i = 0, m if (p > 0) then - accel_mag(i, j, k) = sqrt(x_accel(i, j, k)**2d0 + & - y_accel(i, j, k)**2d0 + & - z_accel(i, j, k)**2d0) + 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)**2d0 + & - y_accel(i, j, k)**2d0) + 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 @@ -188,7 +188,7 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, 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(kind(0d0)), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf + real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf integer :: j, k, l, r !< Generic loop iterators @@ -198,10 +198,10 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & do k = 0, n do j = 0, m - q_sf(j, k, l) = (11d0*q_prim_vf0(mom_idx%beg)%sf(j, k, l) & - - 18d0*q_prim_vf1(mom_idx%beg)%sf(j, k, l) & - + 9d0*q_prim_vf2(mom_idx%beg)%sf(j, k, l) & - - 2d0*q_prim_vf3(mom_idx%beg)%sf(j, k, l))/(6d0*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(mom_idx%beg)%sf(j, k, l) & + - 18._wp*q_prim_vf1(mom_idx%beg)%sf(j, k, l) & + + 9._wp*q_prim_vf2(mom_idx%beg)%sf(j, k, l) & + - 2._wp*q_prim_vf3(mom_idx%beg)%sf(j, k, l))/(6._wp*dt) do r = -fd_number, fd_number if (n == 0) then ! 1D simulation @@ -244,10 +244,10 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & do k = 0, n do j = 0, m - q_sf(j, k, l) = (11d0*q_prim_vf0(mom_idx%beg + 1)%sf(j, k, l) & - - 18d0*q_prim_vf1(mom_idx%beg + 1)%sf(j, k, l) & - + 9d0*q_prim_vf2(mom_idx%beg + 1)%sf(j, k, l) & - - 2d0*q_prim_vf3(mom_idx%beg + 1)%sf(j, k, l))/(6d0*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(mom_idx%beg + 1)%sf(j, k, l) & + - 18._wp*q_prim_vf1(mom_idx%beg + 1)%sf(j, k, l) & + + 9._wp*q_prim_vf2(mom_idx%beg + 1)%sf(j, k, l) & + - 2._wp*q_prim_vf3(mom_idx%beg + 1)%sf(j, k, l))/(6._wp*dt) do r = -fd_number, fd_number if (p == 0) then ! 2D simulation @@ -265,7 +265,7 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & q_prim_vf0(mom_idx%beg + 1)%sf(j, r + k, l) & + q_prim_vf0(mom_idx%end)%sf(j, k, l)*fd_coeff_z(r, l)* & q_prim_vf0(mom_idx%beg + 1)%sf(j, k, r + l)/y_cc(k) & - - (q_prim_vf0(mom_idx%end)%sf(j, k, l)**2d0)/y_cc(k) + - (q_prim_vf0(mom_idx%end)%sf(j, k, l)**2._wp)/y_cc(k) else q_sf(j, k, l) = q_sf(j, k, l) & + q_prim_vf0(mom_idx%beg)%sf(j, k, l)*fd_coeff_x(r, j)* & @@ -286,10 +286,10 @@ subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & do l = 0, p do k = 0, n do j = 0, m - q_sf(j, k, l) = (11d0*q_prim_vf0(mom_idx%end)%sf(j, k, l) & - - 18d0*q_prim_vf1(mom_idx%end)%sf(j, k, l) & - + 9d0*q_prim_vf2(mom_idx%end)%sf(j, k, l) & - - 2d0*q_prim_vf3(mom_idx%end)%sf(j, k, l))/(6d0*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(mom_idx%end)%sf(j, k, l) & + - 18._wp*q_prim_vf1(mom_idx%end)%sf(j, k, l) & + + 9._wp*q_prim_vf2(mom_idx%end)%sf(j, k, l) & + - 2._wp*q_prim_vf3(mom_idx%end)%sf(j, k, l))/(6._wp*dt) do r = -fd_number, fd_number if (grid_geometry == 3) then diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 58fb51be77..0a2bc86c50 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -52,14 +52,14 @@ module m_fftw !$acc declare create(real_size, cmplx_size, x_size, batch_size, Nfq) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), data_real_gpu) - @:CRAY_DECLARE_GLOBAL(complex(kind(0d0)), dimension(:), data_cmplx_gpu) - @:CRAY_DECLARE_GLOBAL(complex(kind(0d0)), dimension(:), data_fltr_cmplx_gpu) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), data_real_gpu) + @:CRAY_DECLARE_GLOBAL(complex(wp), dimension(:), data_cmplx_gpu) + @:CRAY_DECLARE_GLOBAL(complex(wp), dimension(:), data_fltr_cmplx_gpu) !$acc declare link(data_real_gpu, data_cmplx_gpu, data_fltr_cmplx_gpu) #else - real(kind(0d0)), allocatable, target :: data_real_gpu(:) - complex(kind(0d0)), allocatable, target :: data_cmplx_gpu(:) - complex(kind(0d0)), allocatable, target :: data_fltr_cmplx_gpu(:) + real(wp), allocatable, target :: data_real_gpu(:) + complex(wp), allocatable, target :: data_cmplx_gpu(:) + complex(wp), allocatable, target :: data_fltr_cmplx_gpu(:) !$acc declare create(data_real_gpu, data_cmplx_gpu, data_fltr_cmplx_gpu) #endif @@ -153,7 +153,7 @@ contains do k = 1, sys_size do j = 0, m do l = 1, cmplx_size - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = (0d0, 0d0) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = (0._wp, 0._wp) end do end do end do @@ -205,7 +205,7 @@ 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, kind(0d0)) + 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, wp) 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 @@ -217,7 +217,7 @@ contains do k = 1, sys_size do j = 0, m do l = 1, cmplx_size - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = (0d0, 0d0) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = (0._wp, 0._wp) end do end do end do @@ -240,7 +240,7 @@ contains #endif !$acc end host_data - Nfq = min(floor(2d0*real(i, kind(0d0))*pi), cmplx_size) + Nfq = min(floor(2._wp*real(i, wp)*pi), cmplx_size) !$acc update device(Nfq) !$acc parallel loop collapse(3) gang vector default(present) @@ -265,7 +265,7 @@ 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, kind(0d0)) + 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, wp) 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 @@ -277,27 +277,27 @@ contains Nfq = 3 do j = 0, m do k = 1, sys_size - data_fltr_cmplx(:) = (0d0, 0d0) + data_fltr_cmplx(:) = (0._wp, 0._wp) 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, kind(0d0)) + data_real(:) = data_real(:)/real(real_size, wp) q_cons_vf(k)%sf(j, 0, 0:p) = data_real(1:p + 1) end do end do ! Apply Fourier filter to additional rings do i = 1, fourier_rings - Nfq = min(floor(2d0*real(i, kind(0d0))*pi), cmplx_size) + Nfq = min(floor(2._wp*real(i, wp)*pi), cmplx_size) do j = 0, m do k = 1, sys_size - data_fltr_cmplx(:) = (0d0, 0d0) + data_fltr_cmplx(:) = (0._wp, 0._wp) 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, kind(0d0)) + data_real(:) = data_real(:)/real(real_size, wp) q_cons_vf(k)%sf(j, i, 0:p) = data_real(1:p + 1) end do end do diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index fda004d798..56fb8a52e9 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -30,7 +30,7 @@ module m_global_parameters implicit none - real(kind(0d0)) :: time = 0 + real(wp) :: time = 0 ! Logistics ================================================================ integer :: num_procs !< Number of processors @@ -62,18 +62,18 @@ module m_global_parameters !> @name Cell-boundary (CB) locations in the x-, y- and z-directions, respectively !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), x_cb, y_cb, z_cb) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), x_cb, y_cb, z_cb) #else - real(kind(0d0)), target, allocatable, dimension(:) :: x_cb, y_cb, z_cb + real(wp), target, allocatable, dimension(:) :: x_cb, y_cb, z_cb #endif !> @} !> @name Cell-center (CC) locations in the x-, y- and z-directions, respectively !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), x_cc, y_cc, z_cc) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), x_cc, y_cc, z_cc) #else - real(kind(0d0)), target, allocatable, dimension(:) :: x_cc, y_cc, z_cc + real(wp), target, allocatable, dimension(:) :: x_cc, y_cc, z_cc #endif !> @} !type(bounds_info) :: x_domain, y_domain, z_domain !< @@ -81,13 +81,13 @@ module m_global_parameters !> @name Cell-width distributions in the x-, y- and z-directions, respectively !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), dx, dy, dz) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), dx, dy, dz) #else - real(kind(0d0)), target, allocatable, dimension(:) :: dx, dy, dz + real(wp), target, allocatable, dimension(:) :: dx, dy, dz #endif !> @} - real(kind(0d0)) :: dt !< Size of the time-step + real(wp) :: dt !< Size of the time-step #ifdef CRAY_ACC_WAR !$acc declare link(x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz) @@ -104,7 +104,7 @@ module m_global_parameters !> @name Starting time, stopping time, and time between backups, simulation time, !! and prescribed cfl respectively !> @{ - real(kind(0d0)) :: t_stop, t_save, cfl_target + real(wp) :: t_stop, t_save, cfl_target integer :: n_start !> @} !$acc declare create(cfl_target) @@ -144,8 +144,8 @@ module m_global_parameters logical :: teno !< TENO (Targeted ENO) #:endif - real(kind(0d0)) :: weno_eps !< Binding for the WENO nonlinear weights - real(kind(0d0)) :: teno_CT !< Smoothness threshold for TENO + 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 @@ -165,10 +165,10 @@ module m_global_parameters !< amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} - real(kind(0d0)) :: ${param}$_${dir}$ + real(wp) :: ${param}$_${dir}$ #:endfor #:endfor - real(kind(0d0)), dimension(3) :: accel_bf + real(wp), dimension(3) :: accel_bf !$acc declare create(accel_bf) integer :: cpu_start, cpu_end, cpu_rate @@ -181,8 +181,8 @@ module m_global_parameters logical :: relax !< activate phase change integer :: relax_model !< Relaxation model - real(kind(0d0)) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(kind(0d0)) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change 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 !#ifndef _CRAYFTN !$acc declare create(relax, relax_model, palpha_eps,ptgalpha_eps) @@ -262,7 +262,7 @@ module m_global_parameters ! values or simply, the unaltered left and right, WENO-reconstructed, cell- ! boundary values. !> @{ - real(kind(0d0)) :: wa_flg + real(wp) :: wa_flg !> @{ !$acc declare create(wa_flg) @@ -273,7 +273,7 @@ module m_global_parameters !! the dimensionally split system of equations. !> @{ integer, dimension(3) :: dir_idx - real(kind(0d0)), dimension(3) :: dir_flg + real(wp), dimension(3) :: dir_flg integer, dimension(3) :: dir_idx_tau !!used for hypoelasticity=true !> @} @@ -322,7 +322,7 @@ module m_global_parameters !> @name Reference density and pressure for Tait EOS !> @{ - real(kind(0d0)) :: rhoref, pref + real(wp) :: rhoref, pref !> @} !$acc declare create(rhoref, pref) @@ -351,19 +351,19 @@ module m_global_parameters integer :: nb !< Number of eq. bubble sizes #:endif - real(kind(0d0)) :: R0ref !< Reference bubble size - real(kind(0d0)) :: Ca !< Cavitation number - real(kind(0d0)) :: Web !< Weber number - real(kind(0d0)) :: Re_inv !< Inverse Reynolds number + real(wp) :: R0ref !< Reference bubble size + real(wp) :: Ca !< Cavitation number + real(wp) :: Web !< Weber number + real(wp) :: Re_inv !< Inverse Reynolds number #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), weight) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), R0) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), V0) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), weight) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), R0) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), V0) !$acc declare link(weight, R0, V0) #else - real(kind(0d0)), dimension(:), allocatable :: weight !< Simpson quadrature weights - real(kind(0d0)), dimension(:), allocatable :: R0 !< Bubble sizes - real(kind(0d0)), dimension(:), allocatable :: V0 !< Bubble velocities + real(wp), dimension(:), allocatable :: weight !< Simpson quadrature weights + real(wp), dimension(:), allocatable :: R0 !< Bubble sizes + real(wp), dimension(:), allocatable :: V0 !< Bubble velocities !$acc declare create(weight, R0, V0) #endif logical :: bubbles !< Bubbles on/off @@ -375,13 +375,13 @@ module m_global_parameters integer :: bubble_model !< Gilmore or Keller--Miksis bubble model integer :: thermal !< Thermal behavior. 1 = adiabatic, 2 = isotherm, 3 = transfer #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), ptil) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), ptil) !$acc declare link(ptil) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: ptil !< Pressure modification + real(wp), allocatable, dimension(:, :, :) :: ptil !< Pressure modification !$acc declare create(ptil) #endif - real(kind(0d0)) :: poly_sigma !< log normal sigma for polydisperse PDF + real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF logical :: qbmm !< Quadrature moment method integer, parameter :: nmom = 6 !< Number of carried moments per R0 location @@ -389,7 +389,7 @@ module m_global_parameters integer :: nmomtot !< Total number of carried moments moments/transport equations integer :: R0_type - real(kind(0d0)) :: pi_fac !< Factor for artificial pi_inf + real(wp) :: pi_fac !< Factor for artificial pi_inf #:if not MFC_CASE_OPTIMIZATION !$acc declare create(nb) @@ -413,20 +413,20 @@ module m_global_parameters !> @name Physical bubble parameters (see Ando 2010, Preston 2007) !> @{ - real(kind(0d0)) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v + real(wp) :: R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v !$acc declare create(R_n, R_v, phi_vn, phi_nv, Pe_c, Tw, pv, M_n, M_v) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), k_n, k_v, pb0, mass_n0, mass_v0, Pe_T) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), k_n, k_v, pb0, mass_n0, mass_v0, Pe_T) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN) !$acc declare link( k_n, k_v, pb0, mass_n0, mass_v0, Pe_T, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN) #else - real(kind(0d0)), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T - real(kind(0d0)), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN + real(wp), dimension(:), allocatable :: k_n, k_v, pb0, mass_n0, mass_v0, Pe_T + real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN !$acc declare create( k_n, k_v, pb0, mass_n0, mass_v0, Pe_T, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN) #endif - real(kind(0d0)) :: mul0, ss, gamma_v, mu_v - real(kind(0d0)) :: gamma_m, gamma_n, mu_n - real(kind(0d0)) :: gam + real(wp) :: mul0, ss, gamma_v, mu_v + real(wp) :: gamma_m, gamma_n, mu_n + real(wp) :: gam !> @} !$acc declare create(mul0, ss, gamma_v, mu_v, gamma_m, gamma_n, mu_n, gam) @@ -441,7 +441,7 @@ module m_global_parameters !> @name Surface tension parameters !> @{ - real(kind(0d0)) :: sigma + real(wp) :: sigma !$acc declare create(sigma) !> @} @@ -457,15 +457,15 @@ module m_global_parameters !$acc declare create(momxb, momxe, advxb, advxe, contxb, contxe, intxb, intxe, bubxb, bubxe, strxb, strxe, chemxb, chemxe, tempxb, tempxe) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) !$acc declare link(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) #else - real(kind(0d0)), allocatable, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps + real(wp), allocatable, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) #endif - real(kind(0d0)) :: mytime !< Current simulation time - real(kind(0d0)) :: finaltime !< Final simulation time + real(wp) :: mytime !< Current simulation time + real(wp) :: finaltime !< Final simulation time logical :: weno_flat, riemann_flat, rdma_mpi @@ -563,8 +563,8 @@ contains #:for DIM in ['x', 'y', 'z'] #:for DIR in [1, 2, 3] - bc_${DIM}$%vb${DIR}$ = 0d0 - bc_${DIM}$%ve${DIR}$ = 0d0 + bc_${DIM}$%vb${DIR}$ = 0._wp + bc_${DIM}$%ve${DIR}$ = 0._wp #:endfor #:endfor @@ -576,9 +576,9 @@ contains do i = 1, num_fluids_max fluid_pp(i)%gamma = dflt_real fluid_pp(i)%pi_inf = dflt_real - fluid_pp(i)%cv = 0d0 - fluid_pp(i)%qv = 0d0 - fluid_pp(i)%qvp = 0d0 + fluid_pp(i)%cv = 0._wp + fluid_pp(i)%qv = 0._wp + fluid_pp(i)%qvp = 0._wp fluid_pp(i)%Re(:) = dflt_real fluid_pp(i)%mul0 = dflt_real fluid_pp(i)%ss = dflt_real @@ -587,7 +587,7 @@ contains fluid_pp(i)%M_v = dflt_real fluid_pp(i)%mu_v = dflt_real fluid_pp(i)%k_v = dflt_real - fluid_pp(i)%G = 0d0 + fluid_pp(i)%G = 0._wp end do ! Tait EOS @@ -617,7 +617,7 @@ contains adv_n = .false. adap_dt = .false. - pi_fac = 1d0 + pi_fac = 1._wp ! User inputs for qbmm for simulation code qbmm = .false. @@ -792,9 +792,9 @@ contains @:ALLOCATE(bub_idx%ps(nb), bub_idx%ms(nb)) if (num_fluids == 1) then - gam = 1.d0/fluid_pp(num_fluids + 1)%gamma + 1.d0 + gam = 1._wp/fluid_pp(num_fluids + 1)%gamma + 1._wp else - gam = 1.d0/fluid_pp(num_fluids)%gamma + 1.d0 + gam = 1._wp/fluid_pp(num_fluids)%gamma + 1._wp end if if (qbmm) then @@ -826,11 +826,11 @@ contains end if if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 1d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 1._wp else if (nb > 1) then - V0(:) = 1d0 + V0(:) = 1._wp !R0 and weight initialized in s_simpson else stop 'Invalid value of nb' @@ -839,8 +839,8 @@ contains !Initialize pref,rhoref for polytropic qbmm (done in s_initialize_nonpoly for non-polytropic) if (.not. qbmm) then if (polytropic) then - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if @@ -853,9 +853,9 @@ contains if ((f_is_default(Web))) then pb0 = pref pb0 = pb0/pref - pref = 1d0 + pref = 1._wp end if - rhoref = 1d0 + rhoref = 1._wp end if end if end if @@ -929,18 +929,18 @@ contains end if end do if (nb == 1) then - weight(:) = 1d0 - R0(:) = 1d0 - V0(:) = 0d0 + weight(:) = 1._wp + R0(:) = 1._wp + V0(:) = 0._wp else if (nb > 1) then - V0(:) = 1d0 + V0(:) = 1._wp else stop 'Invalid value of nb' end if if (polytropic) then - rhoref = 1.d0 - pref = 1.d0 + rhoref = 1._wp + pref = 1._wp end if end if end if @@ -1003,7 +1003,7 @@ contains ! using the arithmetic mean of left and right, WENO-reconstructed, ! cell-boundary values or otherwise, the unaltered left and right, ! WENO-reconstructed, cell-boundary values - wa_flg = 0d0; if (weno_avg) wa_flg = 1d0 + wa_flg = 0._wp; if (weno_avg) wa_flg = 1._wp !$acc update device(wa_flg) ! Resort to default WENO-JS if no other WENO scheme is selected diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index e3bb7ec08f..1b66e0df2b 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -23,26 +23,26 @@ module m_hypoelastic s_compute_hypoelastic_rhs #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), Gs) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), Gs) !$acc declare link(Gs) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), du_dx, du_dy, du_dz) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), dv_dx, dv_dy, dv_dz) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), dw_dx, dw_dy, dw_dz) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), du_dx, du_dy, du_dz) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), dv_dx, dv_dy, dv_dz) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), dw_dx, dw_dy, dw_dz) !$acc declare link(du_dx,du_dy,du_dz,dv_dx,dv_dy,dv_dz,dw_dx,dw_dy,dw_dz) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), rho_K_field, G_K_field) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), rho_K_field, G_K_field) !$acc declare link(rho_K_field, G_K_field) #else - real(kind(0d0)), allocatable, dimension(:) :: Gs + real(wp), allocatable, dimension(:) :: Gs !$acc declare create(Gs) - real(kind(0d0)), allocatable, dimension(:, :, :) :: du_dx, du_dy, du_dz - real(kind(0d0)), allocatable, dimension(:, :, :) :: dv_dx, dv_dy, dv_dz - real(kind(0d0)), allocatable, dimension(:, :, :) :: dw_dx, dw_dy, dw_dz + real(wp), allocatable, dimension(:, :, :) :: du_dx, du_dy, du_dz + real(wp), allocatable, dimension(:, :, :) :: dv_dx, dv_dy, dv_dz + real(wp), allocatable, dimension(:, :, :) :: dw_dx, dw_dy, dw_dz !$acc declare create(du_dx,du_dy,du_dz,dv_dx,dv_dy,dv_dz,dw_dx,dw_dy,dw_dz) - real(kind(0d0)), allocatable, dimension(:, :, :) :: rho_K_field, G_K_field + real(wp), allocatable, dimension(:, :, :) :: rho_K_field, G_K_field !$acc declare create(rho_K_field, G_K_field) #endif @@ -82,7 +82,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - real(kind(0d0)) :: rho_K, G_K + real(wp) :: rho_K, G_K integer :: i, k, l, q !< Loop variables integer :: ndirs !< Number of coordinate directions @@ -99,10 +99,10 @@ contains do k = 0, m du_dx(k, l, q) = & (q_prim_vf(momxb)%sf(k - 2, l, q) & - - 8d0*q_prim_vf(momxb)%sf(k - 1, l, q) & - + 8d0*q_prim_vf(momxb)%sf(k + 1, l, q) & + - 8._wp*q_prim_vf(momxb)%sf(k - 1, l, q) & + + 8._wp*q_prim_vf(momxb)%sf(k + 1, l, q) & - q_prim_vf(momxb)%sf(k + 2, l, q)) & - /(12d0*dx(k)) + /(12._wp*dx(k)) end do end do end do @@ -114,22 +114,22 @@ contains do k = 0, m du_dy(k, l, q) = & (q_prim_vf(momxb)%sf(k, l - 2, q) & - - 8d0*q_prim_vf(momxb)%sf(k, l - 1, q) & - + 8d0*q_prim_vf(momxb)%sf(k, l + 1, q) & + - 8._wp*q_prim_vf(momxb)%sf(k, l - 1, q) & + + 8._wp*q_prim_vf(momxb)%sf(k, l + 1, q) & - q_prim_vf(momxb)%sf(k, l + 2, q)) & - /(12d0*dy(l)) + /(12._wp*dy(l)) dv_dx(k, l, q) = & (q_prim_vf(momxb + 1)%sf(k - 2, l, q) & - - 8d0*q_prim_vf(momxb + 1)%sf(k - 1, l, q) & - + 8d0*q_prim_vf(momxb + 1)%sf(k + 1, l, q) & + - 8._wp*q_prim_vf(momxb + 1)%sf(k - 1, l, q) & + + 8._wp*q_prim_vf(momxb + 1)%sf(k + 1, l, q) & - q_prim_vf(momxb + 1)%sf(k + 2, l, q)) & - /(12d0*dx(k)) + /(12._wp*dx(k)) dv_dy(k, l, q) = & (q_prim_vf(momxb + 1)%sf(k, l - 2, q) & - - 8d0*q_prim_vf(momxb + 1)%sf(k, l - 1, q) & - + 8d0*q_prim_vf(momxb + 1)%sf(k, l + 1, q) & + - 8._wp*q_prim_vf(momxb + 1)%sf(k, l - 1, q) & + + 8._wp*q_prim_vf(momxb + 1)%sf(k, l + 1, q) & - q_prim_vf(momxb + 1)%sf(k, l + 2, q)) & - /(12d0*dy(l)) + /(12._wp*dy(l)) end do end do end do @@ -142,34 +142,34 @@ contains do k = 0, m du_dz(k, l, q) = & (q_prim_vf(momxb)%sf(k, l, q - 2) & - - 8d0*q_prim_vf(momxb)%sf(k, l, q - 1) & - + 8d0*q_prim_vf(momxb)%sf(k, l, q + 1) & + - 8._wp*q_prim_vf(momxb)%sf(k, l, q - 1) & + + 8._wp*q_prim_vf(momxb)%sf(k, l, q + 1) & - q_prim_vf(momxb)%sf(k, l, q + 2)) & - /(12d0*dz(q)) + /(12._wp*dz(q)) dv_dz(k, l, q) = & (q_prim_vf(momxb + 1)%sf(k, l, q - 2) & - - 8d0*q_prim_vf(momxb + 1)%sf(k, l, q - 1) & - + 8d0*q_prim_vf(momxb + 1)%sf(k, l, q + 1) & + - 8._wp*q_prim_vf(momxb + 1)%sf(k, l, q - 1) & + + 8._wp*q_prim_vf(momxb + 1)%sf(k, l, q + 1) & - q_prim_vf(momxb + 1)%sf(k, l, q + 2)) & - /(12d0*dz(q)) + /(12._wp*dz(q)) dw_dx(k, l, q) = & (q_prim_vf(momxe)%sf(k - 2, l, q) & - - 8d0*q_prim_vf(momxe)%sf(k - 1, l, q) & - + 8d0*q_prim_vf(momxe)%sf(k + 1, l, q) & + - 8._wp*q_prim_vf(momxe)%sf(k - 1, l, q) & + + 8._wp*q_prim_vf(momxe)%sf(k + 1, l, q) & - q_prim_vf(momxe)%sf(k + 2, l, q)) & - /(12d0*dx(k)) + /(12._wp*dx(k)) dw_dy(k, l, q) = & (q_prim_vf(momxe)%sf(k, l - 2, q) & - - 8d0*q_prim_vf(momxe)%sf(k, l - 1, q) & - + 8d0*q_prim_vf(momxe)%sf(k, l + 1, q) & + - 8._wp*q_prim_vf(momxe)%sf(k, l - 1, q) & + + 8._wp*q_prim_vf(momxe)%sf(k, l + 1, q) & - q_prim_vf(momxe)%sf(k, l + 2, q)) & - /(12d0*dy(l)) + /(12._wp*dy(l)) dw_dz(k, l, q) = & (q_prim_vf(momxe)%sf(k, l, q - 2) & - - 8d0*q_prim_vf(momxe)%sf(k, l, q - 1) & - + 8d0*q_prim_vf(momxe)%sf(k, l, q + 1) & + - 8._wp*q_prim_vf(momxe)%sf(k, l, q - 1) & + + 8._wp*q_prim_vf(momxe)%sf(k, l, q + 1) & - q_prim_vf(momxe)%sf(k, l, q + 2)) & - /(12d0*dz(q)) + /(12._wp*dz(q)) end do end do end do @@ -180,7 +180,7 @@ contains do q = 0, p do l = 0, n do k = 0, m - rho_K = 0d0; G_K = 0d0 + 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(i) !alpha_K(1) * Gs(1) @@ -203,7 +203,7 @@ contains do k = 0, m rhs_vf(strxb)%sf(k, l, q) = & rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & - ((4d0*G_K_field(k, l, q)/3d0) + & + ((4._wp*G_K_field(k, l, q)/3._wp) + & q_prim_vf(strxb)%sf(k, l, q))* & du_dx(k, l, q) end do @@ -219,7 +219,7 @@ contains (q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy(k, l, q) + & q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy(k, l, q) - & q_prim_vf(strxb)%sf(k, l, q)*dv_dy(k, l, q) - & - 2d0*G_K_field(k, l, q)*(1d0/3d0)*dv_dy(k, l, q)) + 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dv_dy(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(k, l, q) + & @@ -228,8 +228,8 @@ contains q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy(k, l, q) + & q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy(k, l, q) - & q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy(k, l, q) + & - 2d0*G_K_field(k, l, q)*(1d0/2d0)*(du_dy(k, l, q) + & - dv_dx(k, l, q))) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dy(k, l, q) + & + dv_dx(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(k, l, q) + & @@ -238,9 +238,9 @@ contains q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) + & q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) - & q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy(k, l, q) + & - 2d0*G_K_field(k, l, q)*(dv_dy(k, l, q) - (1d0/3d0)* & - (du_dx(k, l, q) + & - dv_dy(k, l, q)))) + 2._wp*G_K_field(k, l, q)*(dv_dy(k, l, q) - (1._wp/3._wp)* & + (du_dx(k, l, q) + & + dv_dy(k, l, q)))) end do end do end do @@ -254,7 +254,7 @@ contains (q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz(k, l, q) + & q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz(k, l, q) - & q_prim_vf(strxb)%sf(k, l, q)*dw_dz(k, l, q) - & - 2d0*G_K_field(k, l, q)*(1d0/3d0)*dw_dz(k, l, q)) + 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz(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(k, l, q) + & @@ -265,7 +265,7 @@ contains (q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz(k, l, q) + & q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz(k, l, q) - & q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz(k, l, q) - & - 2d0*G_K_field(k, l, q)*(1d0/3d0)*dw_dz(k, l, q)) + 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz(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(k, l, q) + & @@ -277,8 +277,8 @@ contains q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz(k, l, q) + & q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz(k, l, q) - & q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz(k, l, q) + & - 2d0*G_K_field(k, l, q)*(1d0/2d0)*(du_dz(k, l, q) + & - dw_dx(k, l, q))) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dz(k, l, q) + & + dw_dx(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(k, l, q) + & @@ -290,8 +290,8 @@ contains q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz(k, l, q) + & q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz(k, l, q) - & q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz(k, l, q) + & - 2d0*G_K_field(k, l, q)*(1d0/2d0)*(dv_dz(k, l, q) + & - dw_dy(k, l, q))) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(dv_dz(k, l, q) + & + dw_dy(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(k, l, q) + & @@ -303,10 +303,10 @@ contains q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) + & q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) - & q_prim_vf(strxe)%sf(k, l, q)*dw_dz(k, l, q) + & - 2d0*G_K_field(k, l, q)*(dw_dz(k, l, q) - (1d0/3d0)* & - (du_dx(k, l, q) + & - dv_dy(k, l, q) + & - dw_dz(k, l, q)))) + 2._wp*G_K_field(k, l, q)*(dw_dz(k, l, q) - (1._wp/3._wp)* & + (du_dx(k, l, q) + & + dv_dy(k, l, q) + & + dw_dz(k, l, q)))) end do end do end do diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index a0fa597297..1e688088e0 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -40,8 +40,8 @@ module m_ibm !$acc declare create(ib_markers) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), levelset) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :, :), levelset_norm) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), levelset) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :, :), levelset_norm) @:CRAY_DECLARE_GLOBAL(type(ghost_point), dimension(:), ghost_points) @:CRAY_DECLARE_GLOBAL(type(ghost_point), dimension(:), inner_points) @@ -49,9 +49,9 @@ module m_ibm #else !! Marker for solid cells. 0 if liquid, the patch id of its IB if solid - real(kind(0d0)), dimension(:, :, :, :), allocatable :: levelset + real(wp), dimension(:, :, :, :), allocatable :: levelset !! Matrix of distance to IB - real(kind(0d0)), dimension(:, :, :, :, :), allocatable :: levelset_norm + real(wp), dimension(:, :, :, :, :), allocatable :: levelset_norm !! Matrix of normal vector to IB type(ghost_point), dimension(:), allocatable :: ghost_points type(ghost_point), dimension(:), allocatable :: inner_points @@ -135,31 +135,31 @@ contains dimension(sys_size), & intent(inout) :: q_prim_vf !< Primitive Variables - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), optional, intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), optional, intent(inout) :: pb, mv integer :: i, j, k, l, q, r!< Iterator variables integer :: patch_id !< Patch ID of ghost point - real(kind(0d0)) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables - real(kind(0d0)), dimension(2) :: Re_K - real(kind(0d0)) :: G_K - real(kind(0d0)) :: qv_K - real(kind(0d0)), dimension(num_fluids) :: Gs - - real(kind(0d0)) :: pres_IP, coeff - real(kind(0d0)), dimension(3) :: vel_IP, vel_norm_IP - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_IP, alpha_IP - real(kind(0d0)), dimension(nb) :: r_IP, v_IP, pb_IP, mv_IP - real(kind(0d0)), dimension(nb*nmom) :: nmom_IP - real(kind(0d0)), dimension(nb*nnode) :: presb_IP, massv_IP + 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), dimension(num_fluids) :: Gs + + real(wp) :: pres_IP, coeff + real(wp), dimension(3) :: vel_IP, vel_norm_IP + 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 !! Primitive variables at the image point associated with a ghost point, !! interpolated from surrounding fluid cells. - real(kind(0d0)), dimension(3) :: norm !< Normal vector from GP to IP - real(kind(0d0)), dimension(3) :: physical_loc !< Physical loc of GP - real(kind(0d0)), dimension(3) :: vel_g !< Velocity of GP + 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(kind(0d0)) :: nbub - real(kind(0d0)) :: buf + real(wp) :: nbub + real(wp) :: buf type(ghost_point) :: gp type(ghost_point) :: innerp @@ -176,7 +176,7 @@ contains if (p > 0) then physical_loc = [x_cc(j), y_cc(k), z_cc(l)] else - physical_loc = [x_cc(j), y_cc(k), 0d0] + physical_loc = [x_cc(j), y_cc(k), 0._wp] end if !Interpolate primitive variables at image point associated w/ GP @@ -197,7 +197,7 @@ contains alpha_rho_IP, alpha_IP, pres_IP, vel_IP) end if - dyn_pres = 0d0 + dyn_pres = 0._wp ! Set q_prim_vf params at GP so that mixture vars calculated properly !$acc loop seq @@ -228,7 +228,7 @@ contains vel_norm_IP = sum(vel_IP*norm)*norm vel_g = vel_IP - vel_norm_IP else - vel_g = 0d0 + vel_g = 0._wp end if ! Set momentum @@ -236,7 +236,7 @@ contains 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)/2d0 + vel_g(q - momxb + 1)/2._wp end do ! Set continuity and adv vars @@ -301,7 +301,7 @@ contains !$acc parallel loop gang vector private(physical_loc, dyn_pres, alpha_rho_IP, alpha_IP, vel_g, rho, gamma, pi_inf, Re_K, innerp, j, k, l, q) do i = 1, num_inner_gps - vel_g = 0d0 + vel_g = 0._wp innerp = inner_points(i) j = innerp%loc(1) k = innerp%loc(2) @@ -312,7 +312,7 @@ contains if (p > 0) then physical_loc = [x_cc(j), y_cc(k), z_cc(l)] else - physical_loc = [x_cc(j), y_cc(k), 0d0] + physical_loc = [x_cc(j), y_cc(k), 0._wp] end if !$acc loop seq @@ -324,13 +324,13 @@ contains call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, & alpha_rho_IP, Re_K, j, k, l) - dyn_pres = 0d0 + dyn_pres = 0._wp !$acc loop 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)/2d0 + vel_g(q - momxb + 1)/2._wp end do end do @@ -340,14 +340,14 @@ contains subroutine s_compute_image_points(ghost_points, levelset, levelset_norm) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(in) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(in) :: levelset_norm - - real(kind(0d0)) :: dist - real(kind(0d0)), dimension(3) :: norm - real(kind(0d0)), dimension(3) :: physical_loc - real(kind(0d0)) :: temp_loc - real(kind(0d0)), pointer, dimension(:) :: s_cc => null() + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(in) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(in) :: levelset_norm + + 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 @@ -367,7 +367,7 @@ contains if (p > 0) then physical_loc = [x_cc(i), y_cc(j), z_cc(k)] else - physical_loc = [x_cc(i), y_cc(j), 0d0] + physical_loc = [x_cc(i), y_cc(j), 0._wp] end if ! Calculate and store the precise location of the image point @@ -645,11 +645,11 @@ contains type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points - real(kind(0d0)), dimension(2, 2, 2) :: dist - real(kind(0d0)), dimension(2, 2, 2) :: alpha - real(kind(0d0)), dimension(2, 2, 2) :: interp_coeffs - real(kind(0d0)) :: buf - real(kind(0d0)), dimension(2, 2, 2) :: eta + 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 :: i, j, k, l, q !< Iterator variables integer :: i1, i2, j1, j2, k1, k2 !< Grid indexes @@ -663,8 +663,8 @@ contains i1 = gp%ip_grid(1); i2 = i1 + 1 j1 = gp%ip_grid(2); j2 = j1 + 1 - dist = 0d0 - buf = 1d0 + dist = 0._wp + buf = 1._wp dist(1, 1, 1) = sqrt( & (x_cc(i1) - gp%ip_loc(1))**2 + & (y_cc(j1) - gp%ip_loc(2))**2) @@ -678,26 +678,26 @@ contains (x_cc(i2) - gp%ip_loc(1))**2 + & (y_cc(j2) - gp%ip_loc(2))**2) - interp_coeffs = 0d0 + interp_coeffs = 0._wp if (dist(1, 1, 1) <= 1d-16) then - interp_coeffs(1, 1, 1) = 1d0 + interp_coeffs(1, 1, 1) = 1._wp else if (dist(2, 1, 1) <= 1d-16) then - interp_coeffs(2, 1, 1) = 1d0 + interp_coeffs(2, 1, 1) = 1._wp else if (dist(1, 2, 1) <= 1d-16) then - interp_coeffs(1, 2, 1) = 1d0 + interp_coeffs(1, 2, 1) = 1._wp else if (dist(2, 2, 1) <= 1d-16) then - interp_coeffs(2, 2, 1) = 1d0 + interp_coeffs(2, 2, 1) = 1._wp else - eta(:, :, 1) = 1d0/dist(:, :, 1)**2 - alpha = 1d0 + eta(:, :, 1) = 1._wp/dist(:, :, 1)**2 + alpha = 1._wp patch_id = gp%ib_patch_id - if (ib_markers%sf(i1, j1, 0) /= 0) alpha(1, 1, 1) = 0d0 - if (ib_markers%sf(i2, j1, 0) /= 0) alpha(2, 1, 1) = 0d0 - if (ib_markers%sf(i1, j2, 0) /= 0) alpha(1, 2, 1) = 0d0 - if (ib_markers%sf(i2, j2, 0) /= 0) alpha(2, 2, 1) = 0d0 + if (ib_markers%sf(i1, j1, 0) /= 0) alpha(1, 1, 1) = 0._wp + if (ib_markers%sf(i2, j1, 0) /= 0) alpha(2, 1, 1) = 0._wp + if (ib_markers%sf(i1, j2, 0) /= 0) alpha(1, 2, 1) = 0._wp + if (ib_markers%sf(i2, j2, 0) /= 0) alpha(2, 2, 1) = 0._wp buf = sum(alpha(:, :, 1)*eta(:, :, 1)) - if (buf > 0d0) then + if (buf > 0._wp) then interp_coeffs(:, :, 1) = alpha(:, :, 1)*eta(:, :, 1)/buf else buf = sum(eta(:, :, 1)) @@ -749,37 +749,37 @@ contains (x_cc(i2) - gp%ip_loc(1))**2 + & (y_cc(j2) - gp%ip_loc(2))**2 + & (z_cc(k2) - gp%ip_loc(3))**2) - interp_coeffs = 0d0 - buf = 1d0 + interp_coeffs = 0._wp + buf = 1._wp if (dist(1, 1, 1) <= 1d-16) then - interp_coeffs(1, 1, 1) = 1d0 + interp_coeffs(1, 1, 1) = 1._wp else if (dist(2, 1, 1) <= 1d-16) then - interp_coeffs(2, 1, 1) = 1d0 + interp_coeffs(2, 1, 1) = 1._wp else if (dist(1, 2, 1) <= 1d-16) then - interp_coeffs(1, 2, 1) = 1d0 + interp_coeffs(1, 2, 1) = 1._wp else if (dist(2, 2, 1) <= 1d-16) then - interp_coeffs(2, 2, 1) = 1d0 + interp_coeffs(2, 2, 1) = 1._wp else if (dist(1, 1, 2) <= 1d-16) then - interp_coeffs(1, 1, 2) = 1d0 + interp_coeffs(1, 1, 2) = 1._wp else if (dist(2, 1, 2) <= 1d-16) then - interp_coeffs(2, 1, 2) = 1d0 + interp_coeffs(2, 1, 2) = 1._wp else if (dist(1, 2, 2) <= 1d-16) then - interp_coeffs(1, 2, 2) = 1d0 + interp_coeffs(1, 2, 2) = 1._wp else if (dist(2, 2, 2) <= 1d-16) then - interp_coeffs(2, 2, 2) = 1d0 + interp_coeffs(2, 2, 2) = 1._wp else - eta = 1d0/dist**2 - alpha = 1d0 - if (ib_markers%sf(i1, j1, k1) /= 0) alpha(1, 1, 1) = 0d0 - if (ib_markers%sf(i2, j1, k1) /= 0) alpha(2, 1, 1) = 0d0 - if (ib_markers%sf(i1, j2, k1) /= 0) alpha(1, 2, 1) = 0d0 - if (ib_markers%sf(i2, j2, k1) /= 0) alpha(2, 2, 1) = 0d0 - if (ib_markers%sf(i1, j1, k2) /= 0) alpha(1, 1, 2) = 0d0 - if (ib_markers%sf(i2, j1, k2) /= 0) alpha(2, 1, 2) = 0d0 - if (ib_markers%sf(i1, j2, k2) /= 0) alpha(1, 2, 2) = 0d0 - if (ib_markers%sf(i2, j2, k2) /= 0) alpha(2, 2, 2) = 0d0 + eta = 1._wp/dist**2 + alpha = 1._wp + if (ib_markers%sf(i1, j1, k1) /= 0) alpha(1, 1, 1) = 0._wp + if (ib_markers%sf(i2, j1, k1) /= 0) alpha(2, 1, 1) = 0._wp + if (ib_markers%sf(i1, j2, k1) /= 0) alpha(1, 2, 1) = 0._wp + if (ib_markers%sf(i2, j2, k1) /= 0) alpha(2, 2, 1) = 0._wp + if (ib_markers%sf(i1, j1, k2) /= 0) alpha(1, 1, 2) = 0._wp + if (ib_markers%sf(i2, j1, k2) /= 0) alpha(2, 1, 2) = 0._wp + if (ib_markers%sf(i1, j2, k2) /= 0) alpha(1, 2, 2) = 0._wp + if (ib_markers%sf(i2, j2, k2) /= 0) alpha(2, 2, 2) = 0._wp buf = sum(alpha*eta) - if (buf > 0d0) then + if (buf > 0._wp) then interp_coeffs = alpha*eta/buf else buf = sum(eta) @@ -797,17 +797,17 @@ contains !$acc routine seq type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables type(ghost_point), intent(in) :: gp - real(kind(0d0)), dimension(num_fluids), intent(inout) :: alpha_IP, alpha_rho_IP - real(kind(0d0)), intent(inout) :: pres_IP - real(kind(0d0)), dimension(3), intent(inout) :: vel_IP - real(kind(0d0)), optional, dimension(:), intent(inout) :: r_IP, v_IP, pb_IP, mv_IP - real(kind(0d0)), optional, dimension(:), intent(inout) :: nmom_IP - real(kind(0d0)), optional, dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv - real(kind(0d0)), optional, dimension(:), intent(inout) :: presb_IP, massv_IP + real(wp), dimension(num_fluids), intent(inout) :: alpha_IP, alpha_rho_IP + real(wp), intent(inout) :: pres_IP + real(wp), dimension(3), intent(inout) :: vel_IP + 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(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + 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(kind(0d0)) :: coeff + real(wp) :: coeff i1 = gp%ip_grid(1); i2 = i1 + 1 j1 = gp%ip_grid(2); j2 = j1 + 1 @@ -818,25 +818,25 @@ contains k2 = 0 end if - alpha_rho_IP = 0d0 - alpha_IP = 0d0 - pres_IP = 0d0 - vel_IP = 0d0 + alpha_rho_IP = 0._wp + alpha_IP = 0._wp + pres_IP = 0._wp + vel_IP = 0._wp if (bubbles) then - r_IP = 0d0 - v_IP = 0d0 + r_IP = 0._wp + v_IP = 0._wp if (.not. polytropic) then - mv_IP = 0d0 - pb_IP = 0d0 + mv_IP = 0._wp + pb_IP = 0._wp end if end if if (qbmm) then - nmom_IP = 0d0 + nmom_IP = 0._wp if (.not. polytropic) then - presb_IP = 0d0 - massv_IP = 0d0 + presb_IP = 0._wp + massv_IP = 0._wp end if end if @@ -905,8 +905,8 @@ contains !> Subroutine that computes that bubble wall pressure for Gilmore bubbles subroutine s_compute_levelset(levelset, levelset_norm) - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset - real(kind(0d0)), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm + real(wp), dimension(0:m, 0:n, 0:p, num_ibs), intent(inout) :: levelset + real(wp), dimension(0:m, 0:n, 0:p, num_ibs, 3), intent(inout) :: levelset_norm integer :: i !< Iterator variables integer :: geometry diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index b3d7d53a29..8bff7e8c52 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -33,32 +33,32 @@ module m_mpi_proxy implicit none #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), q_cons_buff_send) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), q_cons_buff_recv) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), q_cons_buff_send) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), q_cons_buff_recv) @:CRAY_DECLARE_GLOBAL(integer, dimension(:), ib_buff_send) @:CRAY_DECLARE_GLOBAL(integer, dimension(:), ib_buff_recv) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), c_divs_buff_send) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), c_divs_buff_recv) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), c_divs_buff_send) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), c_divs_buff_recv) !$acc declare link(q_cons_buff_recv, q_cons_buff_send) !$acc declare link(ib_buff_send, ib_buff_recv) !$acc declare link(c_divs_buff_send, c_divs_buff_recv) #else - real(kind(0d0)), private, allocatable, dimension(:), target :: q_cons_buff_send !< + real(wp), private, allocatable, dimension(:), target :: q_cons_buff_send !< !! This variable is utilized to pack and send the buffer of the cell-average !! conservative variables, for a single computational domain boundary at the !! time, to the relevant neighboring processor. - real(kind(0d0)), private, allocatable, dimension(:), target :: q_cons_buff_recv !< + real(wp), private, allocatable, dimension(:), target :: q_cons_buff_recv !< !! q_cons_buff_recv is utilized to receive and unpack the buffer of the cell- !! average conservative variables, for a single computational domain boundary !! at the time, from the relevant neighboring processor. - real(kind(0d0)), private, allocatable, dimension(:), target :: c_divs_buff_send !< + real(wp), private, allocatable, dimension(:), target :: c_divs_buff_send !< !! c_divs_buff_send is utilized to send and unpack the buffer of the cell- !! centered color function derivatives, for a single computational domain !! boundary at the time, to the the relevant neighboring processor - real(kind(0d0)), private, allocatable, dimension(:), target :: c_divs_buff_recv + real(wp), private, allocatable, dimension(:), target :: c_divs_buff_recv !! c_divs_buff_recv is utilized to receiver and unpack the buffer of the cell- !! centered color function derivatives, for a single computational domain !! boundary at the time, from the relevant neighboring processor @@ -183,7 +183,7 @@ contains #:for VAR in ['k_x', 'k_y', 'k_z', 'w_x', 'w_y', 'w_z', 'p_x', 'p_y', & & 'p_z', 'g_x', 'g_y', 'g_z'] - call MPI_BCAST(${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor #:for VAR in ['t_step_old', 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & @@ -220,7 +220,7 @@ contains & 'bc_z%vb1','bc_z%vb2','bc_z%vb3','bc_z%ve1','bc_z%ve2','bc_z%ve3', & & 'x_domain%beg', 'x_domain%end', 'y_domain%beg', 'y_domain%end', & & 'z_domain%beg', 'z_domain%end', 't_stop', 't_save', 'cfl_target'] - call MPI_BCAST(${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor #:if not MFC_CASE_OPTIMIZATION @@ -235,22 +235,22 @@ contains do i = 1, num_fluids_max #:for VAR in [ 'gamma','pi_inf','mul0','ss','pv','gamma_v','M_v', & & 'mu_v','k_v','G', 'cv', 'qv', 'qvp' ] - call MPI_BCAST(fluid_pp(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor - call MPI_BCAST(fluid_pp(i)%Re(1), 2, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(fluid_pp(i)%Re(1), 2, mpi_p, 0, MPI_COMM_WORLD, ierr) end do do i = 1, num_ibs #:for VAR in [ 'radius', 'length_x', 'length_y', & & 'x_centroid', 'y_centroid', 'c', 'm', 'p', 't', 'theta', 'slip' ] - call MPI_BCAST(patch_ib(i)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(patch_ib(i)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor call MPI_BCAST(patch_ib(i)%geometry, 2, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) end do do j = 1, num_probes_max do i = 1, 3 - call MPI_BCAST(acoustic(j)%loc(i), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(acoustic(j)%loc(i), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) end do call MPI_BCAST(acoustic(j)%dipole, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) @@ -263,15 +263,15 @@ contains 'wavelength', 'frequency', 'gauss_sigma_dist', 'gauss_sigma_time', & 'npulse', 'dir', 'delay', 'foc_length', 'aperture', & 'element_spacing_angle', 'element_polygon_ratio', 'rotate_angle' ] - call MPI_BCAST(acoustic(j)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(acoustic(j)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor #:for VAR in [ 'x','y','z' ] - call MPI_BCAST(probe(j)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(probe(j)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor #:for VAR in [ 'xmin', 'xmax', 'ymin', 'ymax', 'zmin', 'zmax' ] - call MPI_BCAST(integral(j)%${VAR}$, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(integral(j)%${VAR}$, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor end do @@ -292,10 +292,10 @@ contains integer :: num_procs_x, num_procs_y, num_procs_z !< !! Optimal number of processors in the x-, y- and z-directions - real(kind(0d0)) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z !< + 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(kind(0d0)) :: fct_min !< + real(wp) :: fct_min !< !! Processor factorization (fct) minimization parameter integer :: MPI_COMM_CART !< @@ -334,8 +334,8 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*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 @@ -378,10 +378,10 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10d0*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + 10d0*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 @@ -501,8 +501,8 @@ contains ! Benchmarking the quality of this initial guess tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y - fct_min = 10d0*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 @@ -682,9 +682,9 @@ contains ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV( & dx(m - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & dx(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only @@ -692,9 +692,9 @@ contains ! Send/receive buffer to/from bc_x%beg/bc_x%beg call MPI_SENDRECV( & dx(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & dx(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 0, & + mpi_p, bc_x%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -706,9 +706,9 @@ contains ! Send/receive buffer to/from bc_x%beg/bc_x%end call MPI_SENDRECV( & dx(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%beg, 1, & + mpi_p, bc_x%beg, 1, & dx(m + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only @@ -716,9 +716,9 @@ contains ! Send/receive buffer to/from bc_x%end/bc_x%end call MPI_SENDRECV( & dx(m - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 0, & + mpi_p, bc_x%end, 0, & dx(m + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_x%end, 1, & + mpi_p, bc_x%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -736,9 +736,9 @@ contains ! Send/receive buffer to/from bc_y%end/bc_y%beg call MPI_SENDRECV( & dy(n - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & + mpi_p, bc_y%end, 0, & dy(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only @@ -746,9 +746,9 @@ contains ! Send/receive buffer to/from bc_y%beg/bc_y%beg call MPI_SENDRECV( & dy(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + mpi_p, bc_y%beg, 1, & dy(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 0, & + mpi_p, bc_y%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -760,9 +760,9 @@ contains ! Send/receive buffer to/from bc_y%beg/bc_y%end call MPI_SENDRECV( & dy(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%beg, 1, & + mpi_p, bc_y%beg, 1, & dy(n + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only @@ -770,9 +770,9 @@ contains ! Send/receive buffer to/from bc_y%end/bc_y%end call MPI_SENDRECV( & dy(n - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 0, & + mpi_p, bc_y%end, 0, & dy(n + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_y%end, 1, & + mpi_p, bc_y%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -790,9 +790,9 @@ contains ! Send/receive buffer to/from bc_z%end/bc_z%beg call MPI_SENDRECV( & dz(p - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & dz(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only @@ -800,9 +800,9 @@ contains ! Send/receive buffer to/from bc_z%beg/bc_z%beg call MPI_SENDRECV( & dz(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & dz(-buff_size), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 0, & + mpi_p, bc_z%beg, 0, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -814,9 +814,9 @@ contains ! Send/receive buffer to/from bc_z%beg/bc_z%end call MPI_SENDRECV( & dz(0), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%beg, 1, & + mpi_p, bc_z%beg, 1, & dz(p + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only @@ -824,9 +824,9 @@ contains ! Send/receive buffer to/from bc_z%end/bc_z%end call MPI_SENDRECV( & dz(p - buff_size + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 0, & + mpi_p, bc_z%end, 0, & dz(p + 1), buff_size, & - MPI_DOUBLE_PRECISION, bc_z%end, 1, & + mpi_p, bc_z%end, 1, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if @@ -852,7 +852,7 @@ contains pbc_loc) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, mv integer, intent(in) :: mpi_dir, pbc_loc integer :: i, j, k, l, r, q !< Generic loop iterators @@ -867,7 +867,7 @@ contains integer :: pack_offsets(1:3), unpack_offsets(1:3) integer :: pack_offset, unpack_offset - real(kind(0d0)), pointer :: p_send, p_recv + real(wp), pointer :: p_send, p_recv integer, pointer, dimension(:) :: p_i_send, p_i_recv #ifdef MFC_MPI @@ -1078,8 +1078,8 @@ contains #:endif call MPI_SENDRECV( & - p_send, buffer_count, MPI_DOUBLE_PRECISION, dst_proc, send_tag, & - p_recv, buffer_count, MPI_DOUBLE_PRECISION, src_proc, recv_tag, & + p_send, buffer_count, mpi_p, dst_proc, send_tag, & + p_recv, buffer_count, mpi_p, src_proc, recv_tag, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) #:if rdma_mpi @@ -2132,7 +2132,7 @@ contains integer :: pack_offsets(1:3), unpack_offsets(1:3) integer :: pack_offset, unpack_offset - real(kind(0d0)), pointer :: p_send, p_recv + real(wp), pointer :: p_send, p_recv #ifdef MFC_MPI @@ -2238,8 +2238,8 @@ contains #:endif call MPI_SENDRECV( & - p_send, buffer_count, MPI_DOUBLE_PRECISION, dst_proc, send_tag, & - p_recv, buffer_count, MPI_DOUBLE_PRECISION, src_proc, recv_tag, & + p_send, buffer_count, mpi_p, dst_proc, send_tag, & + p_recv, buffer_count, mpi_p, src_proc, recv_tag, & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) #:if rdma_mpi diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index c478495a56..c2f96f3060 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -29,10 +29,10 @@ module m_qbmm private; public :: s_initialize_qbmm_module, s_mom_inv, s_coeff, s_compute_qbmm_rhs #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :, :), momrhs) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :, :), momrhs) !$acc declare link(momrhs) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :, :) :: momrhs + real(wp), allocatable, dimension(:, :, :, :, :) :: momrhs !$acc declare create(momrhs) #endif #:if MFC_CASE_OPTIMIZATION @@ -77,7 +77,7 @@ contains #:endif @:ALLOCATE_GLOBAL(momrhs(3, 0:2, 0:2, nterms, nb)) - momrhs = 0d0 + 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 @@ -87,169 +87,169 @@ contains 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.d0 + i1 - momrhs(2, i1, i2, 1, q) = -1.d0 + i2 - momrhs(3, i1, i2, 1, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 2, q) = 1.d0 + i2 - momrhs(3, i1, i2, 2, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 3, q) = -1.d0 + i2 - momrhs(3, i1, i2, 3, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 4, q) = 1.d0 + i2 - momrhs(3, i1, i2, 4, q) = 0d0 + 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.d0 + i1 + momrhs(1, i1, i2, 5, q) = -2._wp + i1 momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 6, q) = -1.d0 + i2 - momrhs(3, i1, i2, 6, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 7, q) = -1.d0 + i2 - momrhs(3, i1, i2, 7, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 1, q) = 1d0 + i2 - momrhs(3, i1, i2, 1, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 2, q) = 2d0 + i2 - momrhs(3, i1, i2, 2, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 3, q) = 3d0 + i2 - momrhs(3, i1, i2, 3, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 4, q) = -1d0 + i2 - momrhs(3, i1, i2, 4, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 5, q) = -1._wp + i1 momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0d0 + momrhs(3, i1, i2, 5, q) = 0._wp - momrhs(1, i1, i2, 6, q) = -1d0 + i1 - momrhs(2, i1, i2, 6, q) = 1d0 + i2 - momrhs(3, i1, i2, 6, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 7, q) = -1d0 + i2 - momrhs(3, i1, i2, 7, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 8, q) = -1._wp + i1 momrhs(2, i1, i2, 8, q) = i2 - momrhs(3, i1, i2, 8, q) = 0d0 + momrhs(3, i1, i2, 8, q) = 0._wp - momrhs(1, i1, i2, 9, q) = -1d0 + i1 - momrhs(2, i1, i2, 9, q) = 1d0 + i2 - momrhs(3, i1, i2, 9, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 10, q) = -1._wp + i1 momrhs(2, i1, i2, 10, q) = i2 - momrhs(3, i1, i2, 10, q) = 0d0 + momrhs(3, i1, i2, 10, q) = 0._wp - momrhs(1, i1, i2, 11, q) = -1d0 + i1 - momrhs(2, i1, i2, 11, q) = 1d0 + i2 - momrhs(3, i1, i2, 11, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 12, q) = 1d0 + i2 - momrhs(3, i1, i2, 12, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 13, q) = -1d0 + i2 - momrhs(3, i1, i2, 13, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 14, q) = -1._wp + i1 momrhs(2, i1, i2, 14, q) = i2 - momrhs(3, i1, i2, 14, q) = 0d0 + momrhs(3, i1, i2, 14, q) = 0._wp - momrhs(1, i1, i2, 15, q) = -1d0 + i1 - momrhs(2, i1, i2, 15, q) = 1d0 + i2 - momrhs(3, i1, i2, 15, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 16, q) = -2._wp + i1 momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0d0 + momrhs(3, i1, i2, 16, q) = 0._wp - momrhs(1, i1, i2, 17, q) = -2d0 + i1 - momrhs(2, i1, i2, 17, q) = -1d0 + i2 - momrhs(3, i1, i2, 17, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 18, q) = 1d0 + i2 - momrhs(3, i1, i2, 18, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 19, q) = 2d0 + i2 - momrhs(3, i1, i2, 19, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 20, q) = -1d0 + i2 - momrhs(3, i1, i2, 20, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 21, q) = -2._wp + i1 momrhs(2, i1, i2, 21, q) = i2 - momrhs(3, i1, i2, 21, q) = 0d0 + momrhs(3, i1, i2, 21, q) = 0._wp - momrhs(1, i1, i2, 22, q) = -2d0 + i1 - momrhs(2, i1, i2, 22, q) = -1d0 + i2 - momrhs(3, i1, i2, 22, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 23, q) = -2._wp + i1 momrhs(2, i1, i2, 23, q) = i2 - momrhs(3, i1, i2, 23, q) = 0d0 + momrhs(3, i1, i2, 23, q) = 0._wp - momrhs(1, i1, i2, 24, q) = -3d0 + i1 + momrhs(1, i1, i2, 24, q) = -3._wp + i1 momrhs(2, i1, i2, 24, q) = i2 - momrhs(3, i1, i2, 24, q) = 0d0 + momrhs(3, i1, i2, 24, q) = 0._wp - momrhs(1, i1, i2, 25, q) = -3d0 + i1 - momrhs(2, i1, i2, 25, q) = -1d0 + i2 - momrhs(3, i1, i2, 25, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 26, q) = -2._wp + i1 momrhs(2, i1, i2, 26, q) = i2 - momrhs(3, i1, i2, 26, q) = 0d0 + momrhs(3, i1, i2, 26, q) = 0._wp - momrhs(1, i1, i2, 27, q) = -1d0 + i1 - momrhs(2, i1, i2, 27, q) = -1d0 + i2 - momrhs(3, i1, i2, 27, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 28, q) = -1._wp + i1 momrhs(2, i1, i2, 28, q) = i2 - momrhs(3, i1, i2, 28, q) = 0d0 + momrhs(3, i1, i2, 28, q) = 0._wp - momrhs(1, i1, i2, 29, q) = -2d0 + i1 + momrhs(1, i1, i2, 29, q) = -2._wp + i1 momrhs(2, i1, i2, 29, q) = i2 - momrhs(3, i1, i2, 29, q) = 0d0 + momrhs(3, i1, i2, 29, q) = 0._wp - momrhs(1, i1, i2, 30, q) = -1d0 + i1 - momrhs(2, i1, i2, 30, q) = -1d0 + i2 - momrhs(3, i1, i2, 30, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 31, q) = -1._wp + i1 momrhs(2, i1, i2, 31, q) = i2 - momrhs(3, i1, i2, 31, q) = 0d0 + momrhs(3, i1, i2, 31, q) = 0._wp - momrhs(1, i1, i2, 32, q) = -2d0 + i1 + momrhs(1, i1, i2, 32, q) = -2._wp + i1 momrhs(2, i1, i2, 32, q) = i2 - momrhs(3, i1, i2, 32, q) = 0d0 + momrhs(3, i1, i2, 32, q) = 0._wp end if end if end do; end do @@ -260,145 +260,145 @@ contains 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.d0 + i1 - momrhs(2, i1, i2, 1, q) = -1.d0 + i2 - momrhs(3, i1, i2, 1, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 2, q) = 1.d0 + i2 - momrhs(3, i1, i2, 2, q) = 0d0 + 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.d0 + i1 - 3.d0*gam - momrhs(2, i1, i2, 3, q) = -1.d0 + i2 - momrhs(3, i1, i2, 3, q) = 3.d0*gam + 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.d0 + i1 - momrhs(2, i1, i2, 4, q) = 1.d0 + i2 - momrhs(3, i1, i2, 4, q) = 0d0 + 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.d0 + i1 + momrhs(1, i1, i2, 5, q) = -2._wp + i1 momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 6, q) = -1.d0 + i2 - momrhs(3, i1, i2, 6, q) = 0d0 + 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.d0 + i1 - momrhs(2, i1, i2, 7, q) = -1.d0 + i2 - momrhs(3, i1, i2, 7, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 1, q) = 1d0 + i2 - momrhs(3, i1, i2, 1, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 2, q) = 2d0 + i2 - momrhs(3, i1, i2, 2, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 3, q) = 3d0 + i2 - momrhs(3, i1, i2, 3, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 4, q) = -1d0 + i2 - momrhs(3, i1, i2, 4, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 5, q) = -1._wp + i1 momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0d0 + momrhs(3, i1, i2, 5, q) = 0._wp - momrhs(1, i1, i2, 6, q) = -1d0 + i1 - momrhs(2, i1, i2, 6, q) = 1d0 + i2 - momrhs(3, i1, i2, 6, q) = 0d0 + 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) = -1d0 + i1 - 3d0*gam - momrhs(2, i1, i2, 7, q) = -1d0 + i2 - momrhs(3, i1, i2, 7, q) = 3d0*gam + 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) = -1d0 + i1 - 3d0*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) = 3d0*gam + momrhs(3, i1, i2, 8, q) = 3._wp*gam - momrhs(1, i1, i2, 9, q) = -1d0 + i1 - 3d0*gam - momrhs(2, i1, i2, 9, q) = 1d0 + i2 - momrhs(3, i1, i2, 9, q) = 3d0*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) = -1d0 + i1 - 3d0*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) = 3d0*gam + momrhs(3, i1, i2, 10, q) = 3._wp*gam - momrhs(1, i1, i2, 11, q) = -1d0 + i1 - 3d0*gam - momrhs(2, i1, i2, 11, q) = 1d0 + i2 - momrhs(3, i1, i2, 11, q) = 3d0*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) = -1d0 + i1 - momrhs(2, i1, i2, 12, q) = 1d0 + i2 - momrhs(3, i1, i2, 12, q) = 0d0 + 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) = -1d0 + i1 - momrhs(2, i1, i2, 13, q) = -1d0 + i2 - momrhs(3, i1, i2, 13, q) = 0d0 + 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) = -1d0 + i1 + momrhs(1, i1, i2, 14, q) = -1._wp + i1 momrhs(2, i1, i2, 14, q) = i2 - momrhs(3, i1, i2, 14, q) = 0d0 + momrhs(3, i1, i2, 14, q) = 0._wp - momrhs(1, i1, i2, 15, q) = -1d0 + i1 - momrhs(2, i1, i2, 15, q) = 1d0 + i2 - momrhs(3, i1, i2, 15, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 16, q) = -2._wp + i1 momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0d0 + momrhs(3, i1, i2, 16, q) = 0._wp - momrhs(1, i1, i2, 17, q) = -2d0 + i1 - momrhs(2, i1, i2, 17, q) = -1d0 + i2 - momrhs(3, i1, i2, 17, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 18, q) = 1d0 + i2 - momrhs(3, i1, i2, 18, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 19, q) = 2d0 + i2 - momrhs(3, i1, i2, 19, q) = 0d0 + 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) = -2d0 + i1 - momrhs(2, i1, i2, 20, q) = -1d0 + i2 - momrhs(3, i1, i2, 20, q) = 0d0 + 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) = -2d0 + i1 + momrhs(1, i1, i2, 21, q) = -2._wp + i1 momrhs(2, i1, i2, 21, q) = i2 - momrhs(3, i1, i2, 21, q) = 0d0 + momrhs(3, i1, i2, 21, q) = 0._wp - momrhs(1, i1, i2, 22, q) = -2d0 + i1 - 3d0*gam - momrhs(2, i1, i2, 22, q) = -1d0 + i2 - momrhs(3, i1, i2, 22, q) = 3d0*gam + 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) = -2d0 + i1 - 3d0*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) = 3d0*gam + momrhs(3, i1, i2, 23, q) = 3._wp*gam - momrhs(1, i1, i2, 24, q) = -3d0 + i1 + momrhs(1, i1, i2, 24, q) = -3._wp + i1 momrhs(2, i1, i2, 24, q) = i2 - momrhs(3, i1, i2, 24, q) = 0d0 + momrhs(3, i1, i2, 24, q) = 0._wp - momrhs(1, i1, i2, 25, q) = -3d0 + i1 - momrhs(2, i1, i2, 25, q) = -1d0 + i2 - momrhs(3, i1, i2, 25, q) = 0d0 + 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) = -2d0 + i1 - 3d0*gam + 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) = 3d0*gam + momrhs(3, i1, i2, 26, q) = 3._wp*gam end if end if @@ -431,12 +431,12 @@ contains 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(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv integer :: i, j, k, l, q - real(kind(0d0)) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX + real(wp) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX if (idir == 1) then @@ -455,8 +455,8 @@ contains R = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) R2 = q_prim_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - if (R2 - R**2d0 > 0d0) then - var = R2 - R**2d0 + if (R2 - R**2._wp > 0._wp) then + var = R2 - R**2._wp else var = verysmall end if @@ -471,20 +471,20 @@ contains 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) - 3d0*gam/(dx(j)*AX*nb_q**2)* & + 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)) if (q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dx(j)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dx(j)*AX*nb_q**2*dsqrt(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) + 3d0*gam/(dx(j)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(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) - 3d0*gam/(dx(j)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dx(j)*AX*nb_q**2*dsqrt(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) - 3d0*gam/(dx(j)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(var)*2._wp)* & + (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end do @@ -539,8 +539,8 @@ contains R = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) R2 = q_prim_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - if (R2 - R**2d0 > 0d0) then - var = R2 - R**2d0 + if (R2 - R**2._wp > 0._wp) then + var = R2 - R**2._wp else var = verysmall end if @@ -555,20 +555,20 @@ contains 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) - 3d0*gam/(dy(k)*AX*nb_q**2)* & + 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)) if (q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dy(k)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dy(k)*AX*nb_q**2*dsqrt(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) + 3d0*gam/(dy(k)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(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) - 3d0*gam/(dy(k)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dy(k)*AX*nb_q**2*dsqrt(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) - 3d0*gam/(dy(k)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(var)*2._wp)* & + (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end do @@ -596,8 +596,8 @@ contains R = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) R2 = q_prim_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - if (R2 - R**2d0 > 0d0) then - var = R2 - R**2d0 + if (R2 - R**2._wp > 0._wp) then + var = R2 - R**2._wp else var = verysmall end if @@ -612,20 +612,20 @@ contains 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) - 3d0*gam/(dz(l)*y_cc(k)*AX*nb_q**2)* & + 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)) if (q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*y_cc(k)*AX*nb_q**2*dsqrt(var)*2d0)* & + 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*dsqrt(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) + 3d0*gam/(dz(l)*y_cc(k)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(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) - 3d0*gam/(dz(l)*y_cc(k)*AX*nb_q**2*dsqrt(var)*2d0)* & + 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*dsqrt(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) - 3d0*gam/(dz(l)*y_cc(k)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(var)*2._wp)* & + (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end do end do @@ -647,8 +647,8 @@ contains R = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) R2 = q_prim_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - if (R2 - R**2d0 > 0d0) then - var = R2 - R**2d0 + if (R2 - R**2._wp > 0._wp) then + var = R2 - R**2._wp else var = verysmall end if @@ -663,20 +663,20 @@ contains 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) - 3d0*gam/(dz(l)*AX*nb_q**2)* & + 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)) if (q <= 2) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3d0*gam/(dz(l)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dz(l)*AX*nb_q**2*dsqrt(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) + 3d0*gam/(dz(l)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(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) - 3d0*gam/(dz(l)*AX*nb_q**2*dsqrt(var)*2d0)* & + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*AX*nb_q**2*dsqrt(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) - 3d0*gam/(dz(l)*AX*nb_q**2*dsqrt(var)*2d0)* & - (-2d0*(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*dsqrt(var)*2._wp)* & + (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end do @@ -699,65 +699,65 @@ contains #else !$acc routine seq #endif - real(kind(0.d0)), intent(in) :: pres, rho, c - real(kind(0.d0)), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs + real(kind(0._wp)), intent(in) :: pres, rho, c + real(kind(0._wp)), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs integer :: i1, i2, q - coeffs = 0d0 + coeffs = 0._wp do i2 = 0, 2; do i1 = 0, 2 if ((i1 + i2) <= 2) then if (bubble_model == 3) then ! RPE - coeffs(1, i1, i2) = -1d0*i2*pres/rho - coeffs(2, i1, i2) = -3d0*i2/2d0 + 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) = -4d0*i2*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2d0*i2/Web/rho - coeffs(7, i1, i2) = 0d0 + 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 else if (bubble_model == 2) then ! KM with approximation of 1/(1-V/C) = 1+V/C - coeffs(1, i1, i2) = -3d0*i2/2d0 + coeffs(1, i1, i2) = -3._wp*i2/2._wp coeffs(2, i1, i2) = -i2/c - coeffs(3, i1, i2) = i2/(2d0*c*c) + coeffs(3, i1, i2) = i2/(2._wp*c*c) coeffs(4, i1, i2) = -i2*pres/rho - coeffs(5, i1, i2) = -2d0*i2*pres/(c*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) = 2d0*i2/(c*rho) + coeffs(8, i1, i2) = 2._wp*i2/(c*rho) coeffs(9, i1, i2) = i2/(c*c*rho) - coeffs(10, i1, i2) = -3d0*i2*gam/(c*rho) - coeffs(11, i1, i2) = -3d0*i2*gam/(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) = 0d0 - coeffs(14, i1, i2) = 0d0 - coeffs(15, i1, i2) = 0d0 - if (.not. f_is_default(Re_inv)) coeffs(16, i1, i2) = -i2*4d0*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2d0/Web/rho + 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*6d0*Re_inv/(rho*c) - coeffs(19, i1, i2) = -i2*2d0*Re_inv/(rho*c*c) - coeffs(20, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c) - coeffs(21, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c*c) - coeffs(22, i1, i2) = -i2*4d0/(rho*rho*c) - coeffs(23, i1, i2) = -i2*4d0/(rho*rho*c*c) - coeffs(24, i1, i2) = i2*16d0*Re_inv*Re_inv/(rho*rho*c) + 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/(rho*rho*c) + coeffs(23, i1, i2) = -i2*4._wp/(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*8d0*Re_inv/Web/(rho*rho*c) + coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) end if - coeffs(26, i1, i2) = -12d0*i2*gam*Re_inv/(rho*rho*c*c) + coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) end if - coeffs(27, i1, i2) = 3d0*i2*gam*R_v*Tw/(c*rho) - coeffs(28, i1, i2) = 3d0*i2*gam*R_v*Tw/(c*c*rho) + 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) = 12d0*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) + coeffs(29, i1, i2) = 12._wp*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) end if - coeffs(30, i1, i2) = 3d0*i2*gam/(c*rho) - coeffs(31, i1, i2) = 3d0*i2*gam/(c*c*rho) + 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) = 12d0*i2*gam*Re_inv/(rho*rho*c*c) + coeffs(32, i1, i2) = 12._wp*i2*gam*Re_inv/(rho*rho*c*c) end if end if end if @@ -773,55 +773,55 @@ contains !$acc routine seq #endif - real(kind(0.d0)), intent(inout) :: pres, rho, c - real(kind(0.d0)), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs + real(kind(0._wp)), intent(inout) :: pres, rho, c + real(kind(0._wp)), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs integer :: i1, i2, q - coeffs = 0d0 + coeffs = 0._wp do i2 = 0, 2; do i1 = 0, 2 if ((i1 + i2) <= 2) then if (bubble_model == 3) then ! RPE - coeffs(1, i1, i2) = -1d0*i2*pres/rho - coeffs(2, i1, i2) = -3d0*i2/2d0 + 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) = -4d0*i2*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2d0*i2/Web/rho + 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 else if (bubble_model == 2) then ! KM with approximation of 1/(1-V/C) = 1+V/C - coeffs(1, i1, i2) = -3d0*i2/2d0 + coeffs(1, i1, i2) = -3._wp*i2/2._wp coeffs(2, i1, i2) = -i2/c - coeffs(3, i1, i2) = i2/(2d0*c*c) + coeffs(3, i1, i2) = i2/(2._wp*c*c) coeffs(4, i1, i2) = -i2*pres/rho - coeffs(5, i1, i2) = -2d0*i2*pres/(c*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) = 2d0*i2/(c*rho) + coeffs(8, i1, i2) = 2._wp*i2/(c*rho) coeffs(9, i1, i2) = i2/(c*c*rho) - coeffs(10, i1, i2) = -3d0*i2*gam/(c*rho) - coeffs(11, i1, i2) = -3d0*i2*gam/(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) = 2d0*i2*(pv)/(c*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*4d0*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2d0/Web/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*6d0*Re_inv/(rho*c) - coeffs(19, i1, i2) = -i2*2d0*Re_inv/(rho*c*c) - coeffs(20, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c) - coeffs(21, i1, i2) = i2*4d0*pres*Re_inv/(rho*rho*c*c) - coeffs(22, i1, i2) = -i2*4d0/(rho*rho*c) - coeffs(23, i1, i2) = -i2*4d0/(rho*rho*c*c) - coeffs(24, i1, i2) = i2*16d0*Re_inv*Re_inv/(rho*rho*c) + 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/(rho*rho*c) + coeffs(23, i1, i2) = -i2*4._wp/(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*8d0*Re_inv/Web/(rho*rho*c) + coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) end if - coeffs(26, i1, i2) = -12d0*i2*gam*Re_inv/(rho*rho*c*c) + coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) end if end if end if @@ -834,17 +834,17 @@ contains 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(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv type(int_bounds_info), intent(in) :: ix, iy, iz - real(kind(0d0)), dimension(startx:, starty:, startz:) :: nbub_sc !> Unused Variable not sure what to put as intent + real(wp), dimension(startx:, starty:, startz:) :: nbub_sc !> Unused Variable not sure what to put as intent - real(kind(0d0)), dimension(nmom) :: moms, msum - real(kind(0d0)), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht - real(kind(0d0)), dimension(nterms, 0:2, 0:2) :: mom3d_terms, coeff - real(kind(0d0)) :: pres, rho, nbub, c, alf, R3, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, T_bar, grad_T - real(kind(0d0)) :: start, finish - real(kind(0d0)) :: n_tait, B_tait + real(wp), dimension(nmom) :: moms, msum + real(wp), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht + real(wp), dimension(nterms, 0:2, 0:2) :: mom3d_terms, coeff + real(wp) :: pres, rho, nbub, c, alf, R3, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, T_bar, grad_T + real(wp) :: start, finish + real(wp) :: n_tait, B_tait integer :: j, k, l, q, r, s !< Loop variables integer :: id1, id2, id3 @@ -864,11 +864,11 @@ contains rho = q_prim_vf(contxb)%sf(id1, id2, id3) if (bubble_model == 2) then n_tait = gammas(1) - n_tait = 1.d0/n_tait + 1.d0 !make this the usual little 'gamma' + n_tait = 1._wp/n_tait + 1._wp !make this the usual little 'gamma' B_tait = pi_infs(1)*(n_tait - 1)/n_tait - c = n_tait*(pres + B_tait)*(1d0 - alf)/(rho) + c = n_tait*(pres + B_tait)*(1._wp - alf)/(rho) - if (c > 0.d0) then + if (c > 0._wp) then c = DSQRT(c) else c = sgm_eps @@ -882,7 +882,7 @@ contains end if ! SHB: Manually adjusted pressure here for no-coupling case - ! pres = 1d0/0.3d0 + ! pres = 1._wp/0.3_wp if (alf > small_alf) then nbub = q_cons_vf(bubxb)%sf(id1, id2, id3) @@ -895,7 +895,7 @@ contains moms(r) = q_prim_vf(bubmoms(q, r))%sf(id1, id2, id3) end do - moms(1) = 1d0 + moms(1) = 1._wp call s_chyqmom(moms, wght(:, q), abscX(:, q), abscY(:, q)) @@ -909,13 +909,13 @@ contains !Account for bubble pressure, mass transfer rate and heat transfer rate in wght_pb, wght_mv and wght_ht using Preston model !$acc loop seq do j = 1, nnode - chi_vw = 1.d0/(1.d0 + R_v/R_n*(pb(id1, id2, id3, j, q)/pv - 1.d0)) + chi_vw = 1._wp/(1._wp + R_v/R_n*(pb(id1, id2, id3, j, q)/pv - 1._wp)) x_vw = M_n*chi_vw/(M_v + (M_n - M_v)*chi_vw) - k_mw = x_vw*k_v(q)/(x_vw + (1.d0 - x_vw)*phi_vn) & - + (1.d0 - x_vw)*k_n(q)/(x_vw*phi_nv + 1.d0 - x_vw) + k_mw = x_vw*k_v(q)/(x_vw + (1._wp - x_vw)*phi_vn) & + + (1._wp - x_vw)*k_n(q)/(x_vw*phi_nv + 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_n0(q))) - chi_vw) - rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, q)/Pe_c/(1.d0 - chi_vw)/abscX(j, q) + 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) T_bar = Tw*(pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, q)/R0(q))**3 & *(mass_n0(q) + mass_v0(q))/(mass_n0(q) + mv(id1, id2, id3, j, q)) @@ -935,7 +935,7 @@ contains !$acc loop seq do i1 = 0, 2 if ((i1 + i2) <= 2) then - momsum = 0d0 + momsum = 0._wp !$acc loop seq do j = 1, nterms ! Account for term with pb in Rayleigh Plesset equation @@ -975,48 +975,48 @@ contains do j = 1, nnode ! Compute Rdot (drdt) at quadrature node in the ODE for pb (note this is not the same as bubble variable Rdot) drdt = msum(2) - if (moms(4) - moms(2)**2d0 > 0d0) then + if (moms(4) - moms(2)**2._wp > 0._wp) then if (j == 1 .or. j == 2) then - drdt2 = -1d0/(2d0*dsqrt(moms(4) - moms(2)**2d0)) + drdt2 = -1._wp/(2._wp*dsqrt(moms(4) - moms(2)**2._wp)) else - drdt2 = 1d0/(2d0*dsqrt(moms(4) - moms(2)**2d0)) + drdt2 = 1._wp/(2._wp*dsqrt(moms(4) - moms(2)**2._wp)) end if else ! Edge case where variance < 0 if (j == 1 .or. j == 2) then - drdt2 = -1d0/(2d0*dsqrt(verysmall)) + drdt2 = -1._wp/(2._wp*dsqrt(verysmall)) else - drdt2 = 1d0/(2d0*dsqrt(verysmall)) + drdt2 = 1._wp/(2._wp*dsqrt(verysmall)) end if end if - drdt2 = drdt2*(msum(3) - 2d0*moms(2)*msum(2)) + drdt2 = drdt2*(msum(3) - 2._wp*moms(2)*msum(2)) drdt = drdt + drdt2 - rhs_pb(id1, id2, id3, j, q) = (-3d0*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) + (3d0*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) + (3d0*gam/abscX(j, q))*ht(j, q) - rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q)*(4d0*pi*abscX(j, q)**2d0) + 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))*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 ! Compute special high-order moments - momsp(1)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) - momsp(2)%sf(id1, id2, id3) = 4.d0*pi*nbub*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - momsp(3)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3d0, 2d0, 0d0) - if (abs(gam - 1.d0) <= 1.d-4) then + momsp(1)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3._wp, 0._wp, 0._wp) + momsp(2)%sf(id1, id2, id3) = 4._wp*pi*nbub*f_quad(abscX, abscY, wght, 2._wp, 1._wp, 0._wp) + momsp(3)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght, 3._wp, 2._wp, 0._wp) + if (abs(gam - 1._wp) <= 1.d-4) then ! Gam \approx 1, don't risk imaginary quadrature - momsp(4)%sf(id1, id2, id3) = 1.d0 + momsp(4)%sf(id1, id2, id3) = 1._wp else !Special moment with bubble pressure pb if (polytropic) then - momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3d0*(1d0 - gam), 0d0, 3d0*gam) + pv*f_quad(abscX, abscY, wght, 3d0, 0d0, 0d0) & - - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0/Web)*f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) + 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, 3d0, 0d0, 0d0) & - - 4d0*Re_inv*f_quad(abscX, abscY, wght, 2d0, 1d0, 0d0) - (2d0/Web)*f_quad(abscX, abscY, wght, 2d0, 0d0, 0d0) + 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 @@ -1027,15 +1027,15 @@ contains do i1 = 0, 2 !$acc loop seq do i2 = 0, 2 - moms3d(i1, i2, q)%sf(id1, id2, id3) = 0d0 + moms3d(i1, i2, q)%sf(id1, id2, id3) = 0._wp end do end do end do - momsp(1)%sf(id1, id2, id3) = 0d0 - momsp(2)%sf(id1, id2, id3) = 0d0 - momsp(3)%sf(id1, id2, id3) = 0d0 - momsp(4)%sf(id1, id2, id3) = 0d0 + momsp(1)%sf(id1, id2, id3) = 0._wp + momsp(2)%sf(id1, id2, id3) = 0._wp + momsp(3)%sf(id1, id2, id3) = 0._wp + momsp(4)%sf(id1, id2, id3) = 0._wp end if @@ -1051,14 +1051,14 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(nmom), intent(in) :: momin - real(kind(0d0)), dimension(nnode), intent(inout) :: wght, abscX, abscY + real(wp), dimension(nmom), intent(in) :: momin + real(wp), dimension(nnode), intent(inout) :: wght, abscX, abscY - real(kind(0d0)), dimension(0:2, 0:2) :: moms - real(kind(0d0)), dimension(3) :: M1, M3 - real(kind(0d0)), dimension(2) :: myrho, myrho3, up, up3, Vf - real(kind(0d0)) :: bu, bv, d20, d11, d02, c20, c11, c02 - real(kind(0d0)) :: mu2avg, 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, d02, c20, c11, c02 + real(wp) :: mu2avg, mu2, vp21, vp22, rho21, rho22 moms(0, 0) = momin(1) moms(1, 0) = momin(2) @@ -1073,18 +1073,18 @@ contains d11 = moms(1, 1)/moms(0, 0) d02 = moms(0, 2)/moms(0, 0) - c20 = d20 - bu**2d0; + c20 = d20 - bu**2._wp; c11 = d11 - bu*bv; - c02 = d02 - bv**2d0; - M1 = (/1d0, 0d0, c20/) + c02 = d02 - bv**2._wp; + M1 = (/1._wp, 0._wp, c20/) call s_hyqmom(myrho, up, M1) Vf = c11*up/c20 - mu2avg = c02 - sum(myrho(:)*(Vf(:)**2d0)) + mu2avg = c02 - sum(myrho(:)*(Vf(:)**2._wp)) - mu2avg = maxval((/mu2avg, 0d0/)) + mu2avg = maxval((/mu2avg, 0._wp/)) mu2 = mu2avg - M3 = (/1d0, 0d0, mu2/) + M3 = (/1._wp, 0._wp, mu2/) call s_hyqmom(myrho3, up3, M3) vp21 = up3(1) @@ -1118,16 +1118,16 @@ contains #else !$acc routine seq #endif - real(kind(0d0)), dimension(2), intent(inout) :: frho, fup - real(kind(0d0)), dimension(3), intent(in) :: fmom + real(wp), dimension(2), intent(inout) :: frho, fup + real(wp), dimension(3), intent(in) :: fmom - real(kind(0d0)) :: bu, d2, c2 + real(wp) :: bu, d2, c2 bu = fmom(2)/fmom(1) d2 = fmom(3)/fmom(1) - c2 = d2 - bu**2d0 - frho(1) = fmom(1)/2d0; - frho(2) = fmom(1)/2d0; + c2 = d2 - bu**2._wp + frho(1) = fmom(1)/2._wp; + frho(2) = fmom(1)/2._wp; c2 = maxval((/c2, verysmall/)) fup(1) = bu - DSQRT(c2) fup(2) = bu + DSQRT(c2) @@ -1136,13 +1136,13 @@ contains function f_quad(abscX, abscY, wght_in, q, r, s) !$acc routine seq - real(kind(0.d0)), dimension(nnode, nb), intent(in) :: abscX, abscY, wght_in - real(kind(0.d0)), intent(in) :: q, r, s + real(kind(0._wp)), dimension(nnode, nb), intent(in) :: abscX, abscY, wght_in + real(kind(0._wp)), intent(in) :: q, r, s - real(kind(0.d0)) :: f_quad_RV, f_quad + real(kind(0._wp)) :: f_quad_RV, f_quad integer :: i - f_quad = 0d0 + f_quad = 0._wp do i = 1, nb f_quad_RV = sum(wght_in(:, i)*(abscX(:, i)**q)*(abscY(:, i)**r)) f_quad = f_quad + weight(i)*(R0(i)**s)*f_quad_RV @@ -1152,10 +1152,10 @@ contains function f_quad2D(abscX, abscY, wght_in, pow) !$acc routine seq - real(kind(0.d0)), dimension(nnode), intent(in) :: abscX, abscY, wght_in - real(kind(0.d0)), dimension(3), intent(in) :: pow + real(kind(0._wp)), dimension(nnode), intent(in) :: abscX, abscY, wght_in + real(kind(0._wp)), dimension(3), intent(in) :: pow - real(kind(0.d0)) :: f_quad2D + real(kind(0._wp)) :: f_quad2D f_quad2D = sum(wght_in(:)*(abscX(:)**pow(1))*(abscY(:)**pow(2))) end function f_quad2D diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 2c8b99b5e9..aaf336b29f 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -186,43 +186,43 @@ module m_rhs #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), blkmod1, blkmod2, alpha1, alpha2, Kterm) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), blkmod1, blkmod2, alpha1, alpha2, Kterm) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf) !$acc declare link(blkmod1, blkmod2, alpha1, alpha2, Kterm) !$acc declare link(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf) !$acc declare link(dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: blkmod1, blkmod2, alpha1, alpha2, Kterm - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: 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 !$acc declare create(blkmod1, blkmod2, alpha1, alpha2, Kterm) !$acc declare create(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf) !$acc declare create(dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), gamma_min, pres_inf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), gamma_min, pres_inf) !$acc declare link(gamma_min, pres_inf) #else - real(kind(0d0)), allocatable, dimension(:) :: gamma_min, pres_inf + real(wp), allocatable, dimension(:) :: gamma_min, pres_inf !$acc declare create(gamma_min, pres_inf) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), Res) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), Res) !$acc declare link(Res) #else - real(kind(0d0)), allocatable, dimension(:, :) :: Res + real(wp), allocatable, dimension(:, :) :: Res !$acc declare create(Res) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), nbub) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), nbub) !$acc declare link(nbub) #else - real(kind(0d0)), allocatable, dimension(:, :, :) :: nbub !< Bubble number density + real(wp), allocatable, dimension(:, :, :) :: nbub !< Bubble number density !$acc declare create(nbub) #endif @@ -651,8 +651,8 @@ contains @:ALLOCATE_GLOBAL(gamma_min(1:num_fluids), pres_inf(1:num_fluids)) do i = 1, num_fluids - gamma_min(i) = 1d0/fluid_pp(i)%gamma + 1d0 - pres_inf(i) = fluid_pp(i)%pi_inf/(1d0 + fluid_pp(i)%gamma) + gamma_min(i) = 1._wp/fluid_pp(i)%gamma + 1._wp + pres_inf(i) = fluid_pp(i)%pi_inf/(1._wp + fluid_pp(i)%gamma) end do !$acc update device(gamma_min, pres_inf) @@ -696,7 +696,7 @@ contains do l = startz, p - startz do k = starty, n - starty do j = startx, m - startx - flux_gsrc_n(id)%vf(i)%sf(j, k, l) = 0d0 + flux_gsrc_n(id)%vf(i)%sf(j, k, l) = 0._wp end do end do end do @@ -714,32 +714,32 @@ contains 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 - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: pb, rhs_pb + real(wp), dimension(startx:, starty:, startz:, 1:, 1:), intent(inout) :: mv, rhs_mv integer, intent(in) :: t_step - real(kind(0d0)), intent(inout) :: time_avg + real(wp), intent(inout) :: time_avg - real(kind(0d0)) :: t_start, t_finish - real(kind(0d0)) :: gp_sum + real(wp) :: t_start, t_finish + real(wp) :: gp_sum - real(kind(0d0)) :: top, bottom !< Numerator and denominator when evaluating flux limiter function - real(kind(0d0)), dimension(num_fluids) :: myalpha_rho, myalpha + real(wp) :: top, bottom !< Numerator and denominator when evaluating flux limiter function + real(wp), dimension(num_fluids) :: myalpha_rho, myalpha - real(kind(0d0)) :: tmp1, tmp2, tmp3, tmp4, & - c_gas, c_liquid, & - Cpbw, Cpinf, Cpinf_dot, & - myH, myHdot, rddot, alf_gas + real(wp) :: tmp1, tmp2, tmp3, tmp4, & + c_gas, c_liquid, & + Cpbw, Cpinf, Cpinf_dot, & + myH, myHdot, rddot, alf_gas - real(kind(0d0)) :: n_tait, B_tait, angle, angle_z + real(wp) :: n_tait, B_tait, angle, angle_z - real(kind(0d0)), dimension(nb) :: Rtmp, Vtmp - real(kind(0d0)) :: myR, myV, alf, myP, myRho, R2Vav - real(kind(0d0)), dimension(0:m, 0:n, 0:p) :: nbub + real(wp), dimension(nb) :: Rtmp, Vtmp + real(wp) :: myR, myV, alf, myP, myRho, R2Vav + real(wp), dimension(0:m, 0:n, 0:p) :: nbub integer :: ndirs - real(kind(0d0)) :: sound - real(kind(0d0)) :: start, finish - real(kind(0d0)) :: s2, const_sos, s1 + real(wp) :: sound + real(wp) :: start, finish + real(wp) :: s2, const_sos, s1 integer :: i, c, j, k, l, q, ii, id !< Generic loop iterators integer :: term_index @@ -784,14 +784,14 @@ contains do l = iz%beg, iz%end do k = iy%beg, iy%end do j = ix%beg, ix%end - alf_sum%sf(j, k, l) = 0d0 + alf_sum%sf(j, k, l) = 0._wp !$acc loop seq do i = advxb, advxe - 1 alf_sum%sf(j, k, l) = alf_sum%sf(j, k, l) + q_cons_qp%vf(i)%sf(j, k, l) end do !$acc loop 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.d0 - q_cons_qp%vf(alf_idx)%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 @@ -964,7 +964,7 @@ contains ! RHS additions for viscosity call nvtxStartRange("RHS_add_phys") - if (any(Re_size > 0d0) .or. (.not. f_is_default(sigma))) then + if (any(Re_size > 0._wp) .or. (.not. f_is_default(sigma))) then call s_compute_additional_physics_rhs(id, & q_prim_qp%vf, & rhs_vf, & @@ -1026,7 +1026,7 @@ contains do j = 0, m if (ib_markers%sf(j, k, l) /= 0) then do i = 1, sys_size - rhs_vf(i)%sf(j, k, l) = 0d0 + rhs_vf(i)%sf(j, k, l) = 0._wp end do end if end do @@ -1085,7 +1085,7 @@ contains if (t_step >= 4) then time_avg = (abs(t_finish - t_start) + (t_step - 4)*time_avg)/(t_step - 3) else - time_avg = 0d0 + time_avg = 0._wp end if ! ================================================================== @@ -1107,9 +1107,9 @@ contains do l = 0, p do k = 0, n do j = 0, m - blkmod1(j, k, l) = ((gammas(1) + 1d0)*q_prim_vf%vf(E_idx)%sf(j, k, l) + & + blkmod1(j, k, l) = ((gammas(1) + 1._wp)*q_prim_vf%vf(E_idx)%sf(j, k, l) + & pi_infs(1))/gammas(1) - blkmod2(j, k, l) = ((gammas(2) + 1d0)*q_prim_vf%vf(E_idx)%sf(j, k, l) + & + blkmod2(j, k, l) = ((gammas(2) + 1._wp)*q_prim_vf%vf(E_idx)%sf(j, k, l) + & pi_infs(2))/gammas(2) alpha1(j, k, l) = q_cons_vf%vf(advxb)%sf(j, k, l) @@ -1143,7 +1143,7 @@ contains do q = 0, p do l = 0, n do k = 0, m - rhs_vf(j)%sf(k, l, q) = 1d0/dx(k)* & + rhs_vf(j)%sf(k, l, q) = 1._wp/dx(k)* & (flux_n(1)%vf(j)%sf(k - 1, l, q) & - flux_n(1)%vf(j)%sf(k, l, q)) end do @@ -1158,7 +1158,7 @@ contains do j = 0, m do i = 1, num_fluids rhs_vf(i + intxb - 1)%sf(j, k, l) = & - rhs_vf(i + intxb - 1)%sf(j, k, l) - 1d0/dx(j)* & + rhs_vf(i + intxb - 1)%sf(j, k, l) - 1._wp/dx(j)* & q_cons_vf%vf(i + advxb - 1)%sf(j, k, l)* & q_prim_vf%vf(E_idx)%sf(j, k, l)* & (flux_src_n(1)%vf(advxb)%sf(j, k, l) - & @@ -1176,7 +1176,7 @@ contains do l = 0, n do k = 0, m rhs_vf(j)%sf(k, l, q) = & - rhs_vf(j)%sf(k, l, q) + 1d0/dx(k)* & + rhs_vf(j)%sf(k, l, q) + 1._wp/dx(k)* & q_prim_vf%vf(contxe + idir)%sf(k, l, q)* & (flux_src_n(1)%vf(j)%sf(k - 1, l, q) & - flux_src_n(1)%vf(j)%sf(k, l, q)) @@ -1193,7 +1193,7 @@ contains do l = 0, n do k = 0, m rhs_vf(j)%sf(k, l, q) = & - rhs_vf(j)%sf(k, l, q) + 1d0/dx(k)* & + rhs_vf(j)%sf(k, l, q) + 1._wp/dx(k)* & (q_cons_vf%vf(j)%sf(k, l, q) - Kterm(k, l, q))* & (flux_src_n(1)%vf(j)%sf(k, l, q) & - flux_src_n(1)%vf(j)%sf(k - 1, l, q)) @@ -1206,7 +1206,7 @@ contains do l = 0, n do k = 0, m rhs_vf(j)%sf(k, l, q) = & - rhs_vf(j)%sf(k, l, q) + 1d0/dx(k)* & + rhs_vf(j)%sf(k, l, q) + 1._wp/dx(k)* & (q_cons_vf%vf(j)%sf(k, l, q) + Kterm(k, l, q))* & (flux_src_n(1)%vf(j)%sf(k, l, q) & - flux_src_n(1)%vf(j)%sf(k - 1, l, q)) @@ -1222,7 +1222,7 @@ contains do l = 0, n do k = 0, m rhs_vf(j)%sf(k, l, q) = & - rhs_vf(j)%sf(k, l, q) + 1d0/dx(k)* & + rhs_vf(j)%sf(k, l, q) + 1._wp/dx(k)* & q_cons_vf%vf(j)%sf(k, l, q)* & (flux_src_n(1)%vf(j)%sf(k, l, q) & - flux_src_n(1)%vf(j)%sf(k - 1, l, q)) @@ -1253,7 +1253,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & (flux_n(2)%vf(j)%sf(q, k - 1, l) & - flux_n(2)%vf(j)%sf(q, k, l)) end do @@ -1268,7 +1268,7 @@ contains do j = 0, m do i = 1, num_fluids rhs_vf(i + intxb - 1)%sf(j, k, l) = & - rhs_vf(i + intxb - 1)%sf(j, k, l) - 1d0/dy(k)* & + rhs_vf(i + intxb - 1)%sf(j, k, l) - 1._wp/dy(k)* & q_cons_vf%vf(i + advxb - 1)%sf(j, k, l)* & q_prim_vf%vf(E_idx)%sf(j, k, l)* & (flux_src_n(2)%vf(advxb)%sf(j, k, l) - & @@ -1320,7 +1320,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & q_prim_vf%vf(contxe + idir)%sf(q, k, l)* & (flux_src_n(2)%vf(j)%sf(q, k - 1, l) & - flux_src_n(2)%vf(j)%sf(q, k, l)) @@ -1338,7 +1338,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & (q_cons_vf%vf(j)%sf(q, k, l) - Kterm(q, k, l))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1352,7 +1352,7 @@ contains do q = 0, m rhs_vf(j)%sf(q, k, l) = & rhs_vf(j)%sf(q, k, l) - & - (Kterm(q, k, l)/2d0/y_cc(k))* & + (Kterm(q, k, l)/2._wp/y_cc(k))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & + flux_src_n(2)%vf(j)%sf(q, k - 1, l)) end do @@ -1365,7 +1365,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & (q_cons_vf%vf(j)%sf(q, k, l) + Kterm(q, k, l))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1379,7 +1379,7 @@ contains do q = 0, m rhs_vf(j)%sf(q, k, l) = & rhs_vf(j)%sf(q, k, l) + & - (Kterm(q, k, l)/2d0/y_cc(k))* & + (Kterm(q, k, l)/2._wp/y_cc(k))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & + flux_src_n(2)%vf(j)%sf(q, k - 1, l)) end do @@ -1395,7 +1395,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & q_cons_vf%vf(j)%sf(q, k, l)* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1428,7 +1428,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)/y_cc(q)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)/y_cc(q)* & q_prim_vf%vf(contxe + idir)%sf(l, q, k)* & (flux_n(3)%vf(j)%sf(l, q, k - 1) & - flux_n(3)%vf(j)%sf(l, q, k)) @@ -1458,7 +1458,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)* & (flux_n(3)%vf(j)%sf(l, q, k - 1) & - flux_n(3)%vf(j)%sf(l, q, k)) end do @@ -1474,7 +1474,7 @@ contains do j = 0, m do i = 1, num_fluids rhs_vf(i + intxb - 1)%sf(j, k, l) = & - rhs_vf(i + intxb - 1)%sf(j, k, l) - 1d0/dz(l)* & + rhs_vf(i + intxb - 1)%sf(j, k, l) - 1._wp/dz(l)* & q_cons_vf%vf(i + advxb - 1)%sf(j, k, l)* & q_prim_vf%vf(E_idx)%sf(j, k, l)* & (flux_src_n(3)%vf(advxb)%sf(j, k, l) - & @@ -1493,7 +1493,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & q_prim_vf%vf(contxe + idir)%sf(q, k, l)* & (flux_src_n(2)%vf(j)%sf(q, k - 1, l) & - flux_src_n(2)%vf(j)%sf(q, k, l)) @@ -1511,7 +1511,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & (q_cons_vf%vf(j)%sf(q, k, l) - Kterm(q, k, l))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1525,7 +1525,7 @@ contains do q = 0, m rhs_vf(j)%sf(q, k, l) = & rhs_vf(j)%sf(q, k, l) - & - (Kterm(q, k, l)/2d0/y_cc(k))* & + (Kterm(q, k, l)/2._wp/y_cc(k))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & + flux_src_n(2)%vf(j)%sf(q, k - 1, l)) end do @@ -1538,7 +1538,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & (q_cons_vf%vf(j)%sf(q, k, l) + Kterm(q, k, l))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1552,7 +1552,7 @@ contains do q = 0, m rhs_vf(j)%sf(q, k, l) = & rhs_vf(j)%sf(q, k, l) + & - (Kterm(q, k, l)/2d0/y_cc(k))* & + (Kterm(q, k, l)/2._wp/y_cc(k))* & (flux_src_n(2)%vf(j)%sf(q, k, l) & + flux_src_n(2)%vf(j)%sf(q, k - 1, l)) end do @@ -1568,7 +1568,7 @@ contains do k = 0, n do q = 0, m rhs_vf(j)%sf(q, k, l) = & - rhs_vf(j)%sf(q, k, l) + 1d0/dy(k)* & + rhs_vf(j)%sf(q, k, l) + 1._wp/dy(k)* & q_cons_vf%vf(j)%sf(q, k, l)* & (flux_src_n(2)%vf(j)%sf(q, k, l) & - flux_src_n(2)%vf(j)%sf(q, k - 1, l)) @@ -1586,7 +1586,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)* & q_prim_vf%vf(contxe + idir)%sf(l, q, k)* & (flux_src_n(3)%vf(j)%sf(l, q, k - 1) & - flux_src_n(3)%vf(j)%sf(l, q, k)) @@ -1603,7 +1603,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)* & (q_cons_vf%vf(j)%sf(l, q, k) - Kterm(l, q, k))* & (flux_src_n(3)%vf(j)%sf(l, q, k) & - flux_src_n(3)%vf(j)%sf(l, q, k - 1)) @@ -1616,7 +1616,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)* & (q_cons_vf%vf(j)%sf(l, q, k) + Kterm(l, q, k))* & (flux_src_n(3)%vf(j)%sf(l, q, k) & - flux_src_n(3)%vf(j)%sf(l, q, k - 1)) @@ -1632,7 +1632,7 @@ contains do q = 0, n do l = 0, m rhs_vf(j)%sf(l, q, k) = & - rhs_vf(j)%sf(l, q, k) + 1d0/dz(k)* & + rhs_vf(j)%sf(l, q, k) + 1._wp/dz(k)* & q_cons_vf%vf(j)%sf(l, q, k)* & (flux_src_n(3)%vf(j)%sf(l, q, k) & - flux_src_n(3)%vf(j)%sf(l, q, k - 1)) @@ -1667,7 +1667,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1d0/dx(j)* & + rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dx(j)* & q_prim_vf(c_idx)%sf(j, k, l)* & (flux_src_n(advxb)%sf(j, k, l) - & flux_src_n(advxb)%sf(j - 1, k, l)) @@ -1683,7 +1683,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1d0/dx(j)* & + rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)* & (flux_src_n(i)%sf(j - 1, k, l) & - flux_src_n(i)%sf(j, k, l)) end do @@ -1699,7 +1699,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1d0/dy(k)* & + rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dy(k)* & q_prim_vf(c_idx)%sf(j, k, l)* & (flux_src_n(advxb)%sf(j, k, l) - & flux_src_n(advxb)%sf(j, k - 1, l)) @@ -1732,7 +1732,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, 0, l) = & - rhs_vf(i)%sf(j, 0, l) + 1d0/(y_cc(1) - y_cc(-1))* & + 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 @@ -1748,7 +1748,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1d0/dy(k)* & + rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & (flux_src_n(i)%sf(j, k - 1, l) & - flux_src_n(i)%sf(j, k, l)) end do @@ -1764,7 +1764,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1d0/dy(k)* & + rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & (flux_src_n(i)%sf(j, k - 1, l) & - flux_src_n(i)%sf(j, k, l)) end do @@ -1800,7 +1800,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, 0, l) = & - rhs_vf(i)%sf(j, 0, l) - 1d0/y_cc(0)* & + rhs_vf(i)%sf(j, 0, l) - 1._wp/y_cc(0)* & tau_Re_vf(i)%sf(j, 0, l) end do end do @@ -1834,7 +1834,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1d0/dz(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(advxb)%sf(j, k, l) - & flux_src_n(advxb)%sf(j, k, l - 1)) @@ -1850,7 +1850,7 @@ contains !$acc loop seq do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1d0/dz(l)* & + rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)* & (flux_src_n(i)%sf(j, k, l - 1) & - flux_src_n(i)%sf(j, k, l)) end do @@ -1897,19 +1897,19 @@ contains !! function, liquid stiffness function (two variations of the last two !! ones), shear and volume Reynolds numbers and the Weber numbers !> @{ - real(kind(0d0)) :: pres_relax - real(kind(0d0)), dimension(num_fluids) :: pres_K_init - real(kind(0d0)) :: f_pres - real(kind(0d0)) :: df_pres - real(kind(0d0)), dimension(num_fluids) :: rho_K_s - real(kind(0d0)), dimension(num_fluids) :: alpha_rho - real(kind(0d0)), dimension(num_fluids) :: alpha - real(kind(0d0)) :: sum_alpha - real(kind(0d0)) :: rho - real(kind(0d0)) :: dyn_pres - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf - real(kind(0d0)), dimension(2) :: Re + real(wp) :: pres_relax + real(wp), dimension(num_fluids) :: pres_K_init + real(wp) :: f_pres + real(wp) :: df_pres + real(wp), dimension(num_fluids) :: rho_K_s + real(wp), dimension(num_fluids) :: alpha_rho + real(wp), dimension(num_fluids) :: alpha + real(wp) :: sum_alpha + real(wp) :: rho + real(wp) :: dyn_pres + real(wp) :: gamma + real(wp) :: pi_inf + real(wp), dimension(2) :: Re integer :: i, j, k, l, q, iter !< Generic loop iterators integer :: relax !< Relaxation procedure determination variable @@ -1921,19 +1921,19 @@ contains ! Numerical correction of the volume fractions if (mpp_lim) then - sum_alpha = 0d0 + sum_alpha = 0._wp !$acc loop seq do i = 1, num_fluids - if ((q_cons_vf(i + contxb - 1)%sf(j, k, l) < 0d0) .or. & - (q_cons_vf(i + advxb - 1)%sf(j, k, l) < 0d0)) then - q_cons_vf(i + contxb - 1)%sf(j, k, l) = 0d0 - q_cons_vf(i + advxb - 1)%sf(j, k, l) = 0d0 - q_cons_vf(i + intxb - 1)%sf(j, k, l) = 0d0 + 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) > 1d0) & - q_cons_vf(i + advxb - 1)%sf(j, k, l) = 1d0 + 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 @@ -1950,12 +1950,12 @@ contains !$acc loop seq do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > (1d0 - sgm_eps)) relax = 0 + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > (1._wp - sgm_eps)) relax = 0 end do if (relax == 1) then ! Initial state - pres_relax = 0d0 + pres_relax = 0._wp !$acc loop seq do i = 1, num_fluids @@ -1965,10 +1965,10 @@ contains q_cons_vf(i + advxb - 1)%sf(j, k, l) & - pi_infs(i))/gammas(i) - if (pres_K_init(i) <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & - pres_K_init(i) = -(1d0 - 1d-8)*pres_inf(i) + 1d-8 + if (pres_K_init(i) <= -(1._wp - 1d-8)*pres_inf(i) + 1d-8) & + pres_K_init(i) = -(1._wp - 1d-8)*pres_inf(i) + 1d-8 else - pres_K_init(i) = 0d0 + pres_K_init(i) = 0._wp end if pres_relax = pres_relax + q_cons_vf(i + advxb - 1)%sf(j, k, l)*pres_K_init(i) end do @@ -1979,7 +1979,7 @@ contains !$acc loop seq do i = 1, num_fluids - rho_K_s(i) = 0d0 + rho_K_s(i) = 0._wp end do !$acc loop seq @@ -1990,13 +1990,13 @@ contains ! Physical pressure do i = 1, num_fluids - if (pres_relax <= -(1d0 - 1d-8)*pres_inf(i) + 1d-8) & - pres_relax = -(1d0 - 1d-8)*pres_inf(i) + 1d0 + if (pres_relax <= -(1._wp - 1d-8)*pres_inf(i) + 1d-8) & + pres_relax = -(1._wp - 1d-8)*pres_inf(i) + 1._wp end do ! Newton-Raphson method - f_pres = -1d0 - df_pres = 0d0 + f_pres = -1._wp + df_pres = 0._wp !$acc loop seq do i = 1, num_fluids @@ -2004,7 +2004,7 @@ contains 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 + pres_inf(i))/(pres_K_init(i) + & - pres_inf(i)))**(1d0/gamma_min(i)) + pres_inf(i)))**(1._wp/gamma_min(i)) f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l) & /rho_K_s(i) @@ -2043,9 +2043,9 @@ contains end do if (bubbles) then - rho = 0d0 - gamma = 0d0 - pi_inf = 0d0 + rho = 0._wp + gamma = 0._wp + pi_inf = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then !$acc loop seq @@ -2067,17 +2067,17 @@ contains pi_inf = pi_infs(1) end if else - rho = 0d0 - gamma = 0d0 - pi_inf = 0d0 + rho = 0._wp + gamma = 0._wp + pi_inf = 0._wp - sum_alpha = 0d0 + sum_alpha = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho(i) = max(0d0, alpha_rho(i)) - alpha(i) = min(max(0d0, alpha(i)), 1d0) + alpha_rho(i) = max(0._wp, alpha_rho(i)) + alpha(i) = min(max(0._wp, alpha(i)), 1._wp) sum_alpha = sum_alpha + alpha(i) end do @@ -2097,20 +2097,20 @@ contains do i = 1, 2 Re(i) = dflt_real - if (Re_size(i) > 0) Re(i) = 0d0 + if (Re_size(i) > 0) Re(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re(i) = alpha(Re_idx(i, q))/Res(i, q) & + Re(i) end do - Re(i) = 1d0/max(Re(i), sgm_eps) + Re(i) = 1._wp/max(Re(i), sgm_eps) end do end if end if - dyn_pres = 0d0 + dyn_pres = 0._wp !$acc loop seq do i = momxb, momxe @@ -2147,8 +2147,8 @@ contains norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_x, vL_y, vL_z - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_x, vR_y, vR_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_x, vL_y, vL_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: weno_dir !< Coordinate direction of the WENO reconstruction @@ -2201,8 +2201,8 @@ contains norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_x, vL_y, vL_z - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_x, vR_y, vR_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_x, vL_y, vL_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the WENO reconstruction diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 0210882be8..aa20b94d1c 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -94,9 +94,9 @@ module m_riemann_solvers flux_gsrc_vf, & norm_dir, ix, iy, iz) - import :: scalar_field, int_bounds_info, sys_size, startx, starty, startz + import :: scalar_field, int_bounds_info, sys_size, startx, starty, startz, wp - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(startx:, starty:, startz:, 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 @@ -161,15 +161,15 @@ module m_riemann_solvers !! dqK_prim_ds_vf where ds = dx, dy or dz. !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsx_vf, flux_src_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsy_vf, flux_src_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_rsz_vf, flux_src_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsx_vf, flux_src_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsy_vf, flux_src_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_rsz_vf, flux_src_rsz_vf) !$acc declare link( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) #endif @@ -180,14 +180,14 @@ module m_riemann_solvers !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_gsrc_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_gsrc_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), flux_gsrc_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_gsrc_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_gsrc_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), flux_gsrc_rsz_vf) !$acc declare link( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< !$acc declare create( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) #endif !> @} @@ -195,38 +195,38 @@ module m_riemann_solvers ! 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. #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), vel_src_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), vel_src_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), vel_src_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), vel_src_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), vel_src_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), vel_src_rsz_vf) !$acc declare link(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: 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 !$acc declare create(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), mom_sp_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), mom_sp_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), mom_sp_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), mom_sp_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), mom_sp_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), mom_sp_rsz_vf) !$acc declare link(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: 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 !$acc declare create(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), Re_avg_rsx_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), Re_avg_rsy_vf) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), Re_avg_rsz_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), Re_avg_rsx_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), Re_avg_rsy_vf) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), Re_avg_rsz_vf) !$acc declare link(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) #else - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf - real(kind(0d0)), allocatable, dimension(:, :, :, :) :: 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 !$acc declare link(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) #endif @@ -249,18 +249,18 @@ module m_riemann_solvers !$acc declare create(is1, is2, is3, isx, isy, isz) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:), Gs) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:), Gs) !$acc declare link(Gs) #else - real(kind(0d0)), allocatable, dimension(:) :: Gs + real(wp), allocatable, dimension(:) :: Gs !$acc declare create(Gs) #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), Res) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), Res) !$acc declare link(Res) #else - real(kind(0d0)), allocatable, dimension(:, :) :: Res + real(wp), allocatable, dimension(:, :) :: Res !$acc declare create(Res) #endif @@ -279,7 +279,7 @@ contains flux_gsrc_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(startx:, starty:, startz:, 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 @@ -298,39 +298,39 @@ contains integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(kind(0d0)) :: rho_L, rho_R - real(kind(0d0)), dimension(num_dims) :: vel_L, vel_R - real(kind(0d0)) :: pres_L, pres_R - real(kind(0d0)) :: E_L, E_R - real(kind(0d0)) :: H_L, H_R - real(kind(0d0)), dimension(num_fluids) :: alpha_L, alpha_R - real(kind(0d0)) :: Y_L, Y_R - real(kind(0d0)) :: gamma_L, gamma_R - real(kind(0d0)) :: pi_inf_L, pi_inf_R - real(kind(0d0)) :: qv_L, qv_R - real(kind(0d0)) :: c_L, c_R - real(kind(0d0)), dimension(6) :: tau_e_L, tau_e_R - real(kind(0d0)) :: G_L, G_R - real(kind(0d0)), dimension(2) :: Re_L, Re_R - - real(kind(0d0)) :: rho_avg - real(kind(0d0)), dimension(num_dims) :: vel_avg - real(kind(0d0)) :: H_avg - real(kind(0d0)) :: gamma_avg - real(kind(0d0)) :: c_avg - - real(kind(0d0)) :: s_L, s_R, s_M, s_P, s_S - real(kind(0d0)) :: xi_L, xi_R !< Left and right wave speeds functions - real(kind(0d0)) :: xi_M, xi_P - - real(kind(0d0)) :: nbub_L, nbub_R - real(kind(0d0)) :: ptilde_L, ptilde_R - real(kind(0d0)) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(kind(0d0)) :: blkmod1, blkmod2 - real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star - real(kind(0d0)) :: Ms_L, Ms_R, pres_SL, pres_SR - real(kind(0d0)) :: alpha_L_sum, alpha_R_sum + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_dims) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp) :: 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(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + + real(wp) :: rho_avg + real(wp), dimension(num_dims) :: vel_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_L, xi_R !< Left and right wave speeds functions + real(wp) :: xi_M, xi_P + + real(wp) :: nbub_L, nbub_R + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: blkmod1, blkmod2 + real(wp) :: rho_Star, E_Star, p_Star, p_K_Star + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum integer :: i, j, k, l, q !< Generic loop iterators @@ -373,12 +373,12 @@ contains vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) end do - vel_L_rms = 0d0; vel_R_rms = 0d0 + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_dims - vel_L_rms = vel_L_rms + vel_L(i)**2d0 - vel_R_rms = vel_R_rms + vel_R(i)**2d0 + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do !$acc loop seq @@ -390,24 +390,24 @@ contains pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0d0 - gamma_L = 0d0 - pi_inf_L = 0d0 - qv_L = 0d0 + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp - rho_R = 0d0 - gamma_R = 0d0 - pi_inf_R = 0d0 - qv_R = 0d0 + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp - alpha_L_sum = 0d0 - alpha_R_sum = 0d0 + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho_L(i) = max(0d0, alpha_rho_L(i)) - alpha_L(i) = min(max(0d0, alpha_L(i)), 1d0) + alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) + alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) alpha_L_sum = alpha_L_sum + alpha_L(i) end do @@ -415,8 +415,8 @@ contains !$acc loop seq do i = 1, num_fluids - alpha_rho_R(i) = max(0d0, alpha_rho_R(i)) - alpha_R(i) = min(max(0d0, alpha_R(i)), 1d0) + alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) + alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) alpha_R_sum = alpha_R_sum + alpha_R(i) end do @@ -441,7 +441,7 @@ contains do i = 1, 2 Re_L(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0d0 + if (Re_size(i) > 0) Re_L(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -449,7 +449,7 @@ contains + Re_L(i) end do - Re_L(i) = 1d0/max(Re_L(i), sgm_eps) + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) end do @@ -457,7 +457,7 @@ contains do i = 1, 2 Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_R(i) = 0d0 + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -465,7 +465,7 @@ contains + Re_R(i) end do - Re_R(i) = 1d0/max(Re_R(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -482,8 +482,8 @@ contains tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) end do - G_L = 0d0 - G_R = 0d0 + G_L = 0._wp + G_R = 0._wp !$acc loop seq do i = 1, num_fluids @@ -495,12 +495,12 @@ contains ! 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))/(4d0*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4d0*G_R) + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) ! Additional terms in 2D and 3D if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4d0*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4d0*G_R) + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) end if end if end do @@ -523,23 +523,23 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) end do end if if (wave_speeds == 1) then if (hypoelasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4d0*G_L)/3d0) + & + (((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 + & - (((4d0*G_R)/3d0) + & + (((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 + & - (((4d0*G_R)/3d0) + & + (((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 + & - (((4d0*G_L)/3d0) + & + (((4._wp*G_L)/3._wp) + & tau_e_L(dir_idx_tau(1)))/rho_L)) else s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) @@ -559,12 +559,12 @@ contains pres_SR = pres_SL - Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & - (pres_SL/pres_L - 1d0)*pres_L/ & - ((pres_L + pi_inf_L/(1d0 + gamma_L))))) - Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & - (pres_SR/pres_R - 1d0)*pres_R/ & - ((pres_R + pi_inf_R/(1d0 + gamma_R))))) + Ms_L = max(1._wp, sqrt(1._wp + ((5d-1 + 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 + ((5d-1 + 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 @@ -574,7 +574,7 @@ contains (rho_avg*c_avg)) end if - s_M = min(0d0, s_L); s_P = max(0d0, s_R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) xi_M = (5d-1 + sign(5d-1, s_L)) & + (5d-1 - sign(5d-1, s_L)) & @@ -733,7 +733,7 @@ contains if (bubbles) then ! From HLLC: Kills mass transport @ bubble gas density if (num_fluids > 1) then - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0d0 + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp end if end if @@ -834,7 +834,7 @@ contains flux_gsrc_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(startx:, starty:, startz:, 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 @@ -853,51 +853,51 @@ contains integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - real(kind(0d0)), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(kind(0d0)) :: rho_L, rho_R - real(kind(0d0)), dimension(num_dims) :: vel_L, vel_R - real(kind(0d0)) :: pres_L, pres_R - real(kind(0d0)) :: E_L, E_R - real(kind(0d0)) :: H_L, H_R - real(kind(0d0)), dimension(num_fluids) :: alpha_L, alpha_R - real(kind(0d0)) :: Y_L, Y_R - real(kind(0d0)) :: gamma_L, gamma_R - real(kind(0d0)) :: pi_inf_L, pi_inf_R - real(kind(0d0)) :: qv_L, qv_R - real(kind(0d0)) :: c_L, c_R - real(kind(0d0)), dimension(2) :: Re_L, Re_R - - real(kind(0d0)) :: rho_avg - real(kind(0d0)), dimension(num_dims) :: vel_avg - real(kind(0d0)) :: H_avg - real(kind(0d0)) :: gamma_avg - real(kind(0d0)) :: c_avg - - real(kind(0d0)) :: s_L, s_R, s_M, s_P, s_S - real(kind(0d0)) :: xi_L, xi_R !< Left and right wave speeds functions - real(kind(0d0)) :: xi_M, xi_P - - real(kind(0d0)) :: nbub_L, nbub_R - real(kind(0d0)), dimension(nb) :: R0_L, R0_R - real(kind(0d0)), dimension(nb) :: V0_L, V0_R - real(kind(0d0)), dimension(nb) :: P0_L, P0_R - real(kind(0d0)), dimension(nb) :: pbw_L, pbw_R - real(kind(0d0)), dimension(nb, nmom) :: moms_L, moms_R - real(kind(0d0)) :: ptilde_L, ptilde_R - - real(kind(0d0)) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom - - real(kind(0d0)) :: PbwR3Lbar, Pbwr3Rbar - real(kind(0d0)) :: R3Lbar, R3Rbar - real(kind(0d0)) :: R3V2Lbar, R3V2Rbar - - real(kind(0d0)) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(kind(0d0)) :: vel_L_tmp, vel_R_tmp - real(kind(0d0)) :: blkmod1, blkmod2 - real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star - real(kind(0d0)) :: pres_SL, pres_SR, Ms_L, Ms_R - real(kind(0d0)) :: start, finish - real(kind(0d0)) :: zcoef, pcorr !< low Mach number correction + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_dims) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp) :: 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), dimension(num_dims) :: vel_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_L, xi_R !< Left and right wave speeds functions + real(wp) :: xi_M, xi_P + + real(wp) :: nbub_L, nbub_R + real(wp), dimension(nb) :: R0_L, R0_R + real(wp), dimension(nb) :: V0_L, V0_R + real(wp), dimension(nb) :: P0_L, P0_R + real(wp), dimension(nb) :: pbw_L, pbw_R + real(wp), dimension(nb, nmom) :: moms_L, moms_R + real(wp) :: ptilde_L, ptilde_R + + real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom + + real(wp) :: PbwR3Lbar, Pbwr3Rbar + real(wp) :: R3Lbar, R3Rbar + real(wp) :: R3V2Lbar, R3V2Rbar + + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: blkmod1, blkmod2 + real(wp) :: rho_Star, E_Star, p_Star, p_K_Star + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + real(wp) :: start, finish + real(wp) :: zcoef, pcorr !< low Mach number correction integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi @@ -936,37 +936,37 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end - vel_L_rms = 0d0; vel_R_rms = 0d0 + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2d0 - vel_R_rms = vel_R_rms + vel_R(i)**2d0 + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0d0 - gamma_L = 0d0 - pi_inf_L = 0d0 - qv_L = 0d0 + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp - rho_R = 0d0 - gamma_R = 0d0 - pi_inf_R = 0d0 - qv_R = 0d0 + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp - alpha_L_sum = 0d0 - alpha_R_sum = 0d0 + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1d0) + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do @@ -977,8 +977,8 @@ contains !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1d0) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do @@ -1009,7 +1009,7 @@ contains do i = 1, 2 Re_L(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0d0 + if (Re_size(i) > 0) Re_L(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -1017,7 +1017,7 @@ contains + Re_L(i) end do - Re_L(i) = 1d0/max(Re_L(i), sgm_eps) + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) end do @@ -1025,7 +1025,7 @@ contains do i = 1, 2 Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_R(i) = 0d0 + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -1033,7 +1033,7 @@ contains + Re_R(i) end do - Re_R(i) = 1d0/max(Re_R(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -1061,7 +1061,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) end do end if @@ -1082,12 +1082,12 @@ contains pres_SR = pres_SL - Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & - (pres_SL/pres_L - 1d0)*pres_L/ & - ((pres_L + pi_inf_L/(1d0 + gamma_L))))) - Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & - (pres_SR/pres_R - 1d0)*pres_R/ & - ((pres_R + pi_inf_R/(1d0 + gamma_R))))) + Ms_L = max(1._wp, sqrt(1._wp + ((5d-1 + 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 + ((5d-1 + 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 @@ -1097,7 +1097,7 @@ contains (rho_avg*c_avg)) end if - if (s_L >= 0d0) then + if (s_L >= 0._wp) then p_Star = pres_L ! Only useful to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids @@ -1130,7 +1130,7 @@ contains end if ! Compute right solution state - else if (s_R <= 0d0) then + else if (s_R <= 0._wp) then p_Star = pres_R ! Only useful to recalculate the radial momentum geometric source flux !$acc loop seq @@ -1164,7 +1164,7 @@ contains end if ! Compute left star solution state - else if (s_S >= 0d0) then + else if (s_S >= 0._wp) then xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) rho_Star = rho_L*xi_L E_Star = xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & @@ -1172,8 +1172,8 @@ contains p_Star = rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))) + pres_L !$acc loop seq do i = 1, num_fluids - p_K_Star = (pres_L + pi_infs(i)/(1d0 + gammas(i)))* & - xi_L**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) + p_K_Star = (pres_L + pi_infs(i)/(1._wp + gammas(i)))* & + xi_L**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1)*s_S @@ -1191,7 +1191,7 @@ contains do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = & rho_Star*s_S*(s_S*dir_flg(dir_idx(i)) + vel_L(dir_idx(i))* & - (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star + (1._wp - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_L - vel_L(dir_idx(i))) @@ -1216,8 +1216,8 @@ contains p_Star = rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))) + pres_R !$acc loop seq do i = 1, num_fluids - p_K_Star = (pres_R + pi_infs(i)/(1d0 + gammas(i)))* & - xi_R**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) + p_K_Star = (pres_R + pi_infs(i)/(1._wp + gammas(i)))* & + xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) flux_rs${XYZ}$_vf(j, k, l, i + advxb - 1) = & qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)*s_S @@ -1234,7 +1234,7 @@ contains !$acc loop seq do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & - (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1d0 - dir_flg(dir_idx(i)))) + & + (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1._wp - dir_flg(dir_idx(i)))) + & dir_flg(dir_idx(i))*p_Star vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & @@ -1270,7 +1270,7 @@ contains ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if @@ -1296,11 +1296,11 @@ contains vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) end do - vel_L_rms = 0d0; vel_R_rms = 0d0 + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_dims - vel_L_rms = vel_L_rms + vel_L(i)**2d0 - vel_R_rms = vel_R_rms + vel_R(i)**2d0 + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do !$acc loop seq @@ -1312,10 +1312,10 @@ contains pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0d0 - gamma_L = 0d0 - pi_inf_L = 0d0 - qv_L = 0d0 + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp !$acc loop seq do i = 1, num_fluids rho_L = rho_L + alpha_rho_L(i) @@ -1324,10 +1324,10 @@ contains qv_L = qv_L + alpha_rho_L(i)*qvs(i) end do - rho_R = 0d0 - gamma_R = 0d0 - pi_inf_R = 0d0 - qv_R = 0d0 + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp !$acc loop seq do i = 1, num_fluids rho_R = rho_R + alpha_rho_R(i) @@ -1374,12 +1374,12 @@ contains pres_SR = pres_SL - Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & - (pres_SL/pres_L - 1d0)*pres_L/ & - ((pres_L + pi_inf_L/(1d0 + gamma_L))))) - Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & - (pres_SR/pres_R - 1d0)*pres_R/ & - ((pres_R + pi_inf_R/(1d0 + gamma_R))))) + Ms_L = max(1._wp, sqrt(1._wp + ((5d-1 + 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 + ((5d-1 + 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 @@ -1391,7 +1391,7 @@ contains ! follows Einfeldt et al. ! s_M/P = min/max(0.,s_L/R) - s_M = min(0d0, s_L); s_P = max(0d0, s_R) + 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) ) @@ -1407,9 +1407,9 @@ contains 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 - 1d0)) & + *(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 - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Momentum flux. @@ -1420,13 +1420,13 @@ contains xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(i)) + & s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1d0 - dir_flg(dir_idx(i)))* & + (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 + & - (1d0 - dir_flg(dir_idx(i)))* & + (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 @@ -1437,28 +1437,28 @@ contains 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))*(-1d0*ptilde_L)) & - + xi_P*(dir_flg(dir_idx(i))*(-1d0*ptilde_R)) + 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.d0 + flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp !$acc loop seq do i = alf_idx, alf_idx !only advect the void fraction flux_rs${XYZ}$_vf(j, k, l, i) = & xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + *(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 - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0d0 - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -1469,9 +1469,9 @@ contains 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 - 1d0)) & + *(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 - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do end if @@ -1489,17 +1489,17 @@ contains xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1d0 - dir_flg(dir_idx(1)))* & + (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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (1._wp - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if #:endif @@ -1507,18 +1507,18 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + 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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (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 @@ -1540,23 +1540,23 @@ contains alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - vel_L_rms = 0d0; vel_R_rms = 0d0 + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2d0 - vel_R_rms = vel_R_rms + vel_R(i)**2d0 + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0d0 - gamma_L = 0d0 - pi_inf_L = 0d0 - qv_L = 0d0 + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then @@ -1582,10 +1582,10 @@ contains qv_L = qvs(1) end if - rho_R = 0d0 - gamma_R = 0d0 - pi_inf_R = 0d0 - qv_R = 0d0 + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp if (mpp_lim .and. (num_fluids > 2)) then !$acc loop seq @@ -1616,15 +1616,15 @@ contains do i = 1, 2 Re_L(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0d0 + if (Re_size(i) > 0) Re_L(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) - Re_L(i) = (1d0 - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) end do - Re_L(i) = 1d0/max(Re_L(i), sgm_eps) + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) end do @@ -1632,15 +1632,15 @@ contains do i = 1, 2 Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_R(i) = 0d0 + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) - Re_R(i) = (1d0 - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) end do - Re_R(i) = 1d0/max(Re_R(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if end if @@ -1670,15 +1670,15 @@ contains nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, n_idx) nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, n_idx) else - nbub_L_denom = 0d0 - nbub_R_denom = 0d0 + nbub_L_denom = 0._wp + nbub_R_denom = 0._wp !$acc loop seq do i = 1, nb - nbub_L_denom = nbub_L_denom + (R0_L(i)**3d0)*weight(i) - nbub_R_denom = nbub_R_denom + (R0_R(i)**3d0)*weight(i) + nbub_L_denom = nbub_L_denom + (R0_L(i)**3._wp)*weight(i) + nbub_R_denom = nbub_R_denom + (R0_R(i)**3._wp)*weight(i) end do - nbub_L = (3.d0/(4.d0*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom - nbub_R = (3.d0/(4.d0*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom + nbub_L = (3._wp/(4._wp*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom + nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom end if else !nb stored in 0th moment of first R0 bin in variable conversion module @@ -1690,8 +1690,8 @@ contains do i = 1, nb if (.not. qbmm) then if (polytropic) then - pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0d0) - pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0d0) + pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0._wp) + pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0._wp) else pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), P0_L(i)) pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), P0_R(i)) @@ -1710,25 +1710,25 @@ contains R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) else - PbwR3Lbar = 0d0 - PbwR3Rbar = 0d0 + PbwR3Lbar = 0._wp + PbwR3Rbar = 0._wp - R3Lbar = 0d0 - R3Rbar = 0d0 + R3Lbar = 0._wp + R3Rbar = 0._wp - R3V2Lbar = 0d0 - R3V2Rbar = 0d0 + R3V2Lbar = 0._wp + R3V2Rbar = 0._wp !$acc loop seq do i = 1, nb - PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3.d0)*weight(i) - PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3.d0)*weight(i) + PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) + PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) - R3Lbar = R3Lbar + (R0_L(i)**3.d0)*weight(i) - R3Rbar = R3Rbar + (R0_R(i)**3.d0)*weight(i) + R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) + R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) - R3V2Lbar = R3V2Lbar + (R0_L(i)**3.d0)*(V0_L(i)**2.d0)*weight(i) - R3V2Rbar = R3V2Rbar + (R0_R(i)**3.d0)*(V0_R(i)**2.d0)*weight(i) + R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) + R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) end do end if @@ -1752,11 +1752,11 @@ contains rho_avg = 5d-1*(rho_L + rho_R) H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) - vel_avg_rms = 0d0 + vel_avg_rms = 0._wp !$acc loop seq do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 + vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2._wp end do end if @@ -1776,7 +1776,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) end do end if @@ -1801,12 +1801,12 @@ contains pres_SR = pres_SL - Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & - (pres_SL/pres_L - 1d0)*pres_L/ & - ((pres_L + pi_inf_L/(1d0 + gamma_L))))) - Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & - (pres_SR/pres_R - 1d0)*pres_R/ & - ((pres_R + pi_inf_R/(1d0 + gamma_R))))) + Ms_L = max(1._wp, sqrt(1._wp + ((5d-1 + 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 + ((5d-1 + 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 @@ -1818,7 +1818,7 @@ contains ! follows Einfeldt et al. ! s_M/P = min/max(0.,s_L/R) - s_M = min(0d0, s_L); s_P = max(0d0, s_R) + 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) ) @@ -1833,21 +1833,21 @@ contains if (low_Mach == 1) then @:compute_low_Mach_correction() else - pcorr = 0d0 + pcorr = 0._wp end if !$acc loop seq do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = & xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + *(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 - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (bubbles .and. (num_fluids > 1)) then ! Kill mass transport @ gas density - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0.d0 + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp end if ! Momentum flux. @@ -1861,13 +1861,13 @@ contains xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(i)) + & s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1d0 - dir_flg(dir_idx(i)))* & + (1._wp - dir_flg(dir_idx(i)))* & vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + xi_P*(rho_R*(vel_R(dir_idx(1))* & vel_R(dir_idx(i)) + & s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1d0 - dir_flg(dir_idx(i)))* & + (1._wp - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr @@ -1893,9 +1893,9 @@ contains 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 - 1d0)) & + *(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 - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation @@ -1904,12 +1904,12 @@ contains 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 - 1d0)) & + s_M*(xi_L - 1._wp)) & + xi_P*(vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))* & - s_P*(xi_R - 1d0)) + s_P*(xi_R - 1._wp)) - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0d0 + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0._wp end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -1919,25 +1919,25 @@ contains 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 - 1d0)) & + *(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 - 1d0)) + *(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 - 1d0)) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) + *(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 - 1d0)) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! Geometrical source flux for cylindrical coordinates @@ -1953,17 +1953,17 @@ contains xi_M*(rho_L*(vel_L(dir_idx(1))* & vel_L(dir_idx(1)) + & s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1d0 - dir_flg(dir_idx(1)))* & + (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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (1._wp - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if #:endif @@ -1971,19 +1971,19 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + 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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (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 + & - (1d0 - dir_flg(dir_idx(1)))* & + (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) @@ -2008,38 +2008,38 @@ contains alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - vel_L_rms = 0d0; vel_R_rms = 0d0 + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2d0 - vel_R_rms = vel_R_rms + vel_R(i)**2d0 + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0d0 - gamma_L = 0d0 - pi_inf_L = 0d0 - qv_L = 0d0 + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp - rho_R = 0d0 - gamma_R = 0d0 - pi_inf_R = 0d0 - qv_R = 0d0 + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp - alpha_L_sum = 0d0 - alpha_R_sum = 0d0 + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp ! Change this by splitting it into the cases ! present in the bubbles if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1d0) + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do @@ -2050,8 +2050,8 @@ contains !$acc loop seq do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0d0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1d0) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do @@ -2079,7 +2079,7 @@ contains do i = 1, 2 Re_L(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0d0 + if (Re_size(i) > 0) Re_L(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -2087,7 +2087,7 @@ contains + Re_L(i) end do - Re_L(i) = 1d0/max(Re_L(i), sgm_eps) + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) end do @@ -2095,7 +2095,7 @@ contains do i = 1, 2 Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_R(i) = 0d0 + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) @@ -2103,7 +2103,7 @@ contains + Re_R(i) end do - Re_R(i) = 1d0/max(Re_R(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -2131,7 +2131,7 @@ contains if (any(Re_size > 0)) then !$acc loop seq do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) end do end if @@ -2157,12 +2157,12 @@ contains pres_SR = pres_SL - Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & - (pres_SL/pres_L - 1d0)*pres_L/ & - ((pres_L + pi_inf_L/(1d0 + gamma_L))))) - Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & - (pres_SR/pres_R - 1d0)*pres_R/ & - ((pres_R + pi_inf_R/(1d0 + gamma_R))))) + Ms_L = max(1._wp, sqrt(1._wp + ((5d-1 + 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 + ((5d-1 + gamma_R)/(1._wp + gamma_R))* & + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(idx1) - c_L*Ms_L s_R = vel_R(idx1) + c_R*Ms_R @@ -2174,7 +2174,7 @@ contains ! follows Einfeldt et al. ! s_M/P = min/max(0.,s_L/R) - s_M = min(0d0, s_L); s_P = max(0d0, s_R) + 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) ) @@ -2189,16 +2189,16 @@ contains if (low_Mach == 1) then @:compute_low_Mach_correction() else - pcorr = 0d0 + pcorr = 0._wp end if !$acc loop seq do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = & xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1d0)) + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) end do ! Momentum flux. @@ -2210,13 +2210,13 @@ contains xi_M*(rho_L*(vel_L(idx1)* & vel_L(idxi) + & s_M*(xi_L*(dir_flg(idxi)*s_S + & - (1d0 - dir_flg(idxi))* & + (1._wp - dir_flg(idxi))* & vel_L(idxi)) - vel_L(idxi))) + & dir_flg(idxi)*(pres_L)) & + xi_P*(rho_R*(vel_R(idx1)* & vel_R(idxi) + & s_P*(xi_R*(dir_flg(idxi)*s_S + & - (1d0 - dir_flg(idxi))* & + (1._wp - dir_flg(idxi))* & vel_R(idxi)) - vel_R(idxi))) + & dir_flg(idxi)*(pres_R)) & + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr @@ -2240,9 +2240,9 @@ contains do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = & xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1d0)) + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation @@ -2252,12 +2252,12 @@ contains vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & xi_M*(vel_L(idxi) + & dir_flg(idxi)* & - s_M*(xi_L - 1d0)) & + s_M*(xi_L - 1._wp)) & + xi_P*(vel_R(idxi) + & dir_flg(idxi)* & - s_P*(xi_R - 1d0)) + 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) = 0d0 + !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, idx1) @@ -2276,17 +2276,17 @@ contains xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1d0 - dir_flg(idx1))* & + (1._wp - dir_flg(idx1))* & vel_L(idx1)) - vel_L(idx1)))) & + xi_P*(rho_R*(vel_R(idx1)* & vel_R(idx1) + & s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1d0 - dir_flg(idx1))* & + (1._wp - dir_flg(idx1))* & vel_R(idx1)) - vel_R(idx1)))) ! Geometrical source of the void fraction(s) is zero !$acc loop seq do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if #:endif @@ -2294,19 +2294,19 @@ contains if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0d0 + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & -xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1d0 - dir_flg(idx1))* & + (1._wp - dir_flg(idx1))* & vel_L(idx1)) - vel_L(idx1)))) & - xi_P*(rho_R*(vel_R(idx1)* & vel_R(idx1) + & s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1d0 - dir_flg(idx1))* & + (1._wp - dir_flg(idx1))* & vel_R(idx1)) - vel_R(idx1)))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) @@ -2531,7 +2531,7 @@ contains qR_prim_vf, & norm_dir, ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(startx:, starty:, startz:, 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(:), & @@ -2547,13 +2547,13 @@ contains if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz - dir_idx = (/1, 2, 3/); dir_flg = (/1d0, 0d0, 0d0/) + dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) elseif (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz - dir_idx = (/2, 1, 3/); dir_flg = (/0d0, 1d0, 0d0/) + dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) else is1 = iz; is2 = iy; is3 = ix - dir_idx = (/3, 1, 2/); dir_flg = (/0d0, 0d0, 1d0/) + dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) end if !$acc update device(is1, is2, is3) @@ -2929,7 +2929,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) = 0d0 + flux_src_vf(i)%sf(j, k, l) = 0._wp end do end do end do @@ -2961,7 +2961,7 @@ 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) = 0d0 + flux_src_vf(i)%sf(k, j, l) = 0._wp end do end do end do @@ -2992,7 +2992,7 @@ 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) = 0d0 + flux_src_vf(i)%sf(l, k, j) = 0._wp end do end do end do @@ -3064,13 +3064,13 @@ contains ! Arithmetic mean of the left and right, WENO-reconstructed, cell- ! boundary values of cell-average first-order spatial derivatives ! of velocity - real(kind(0d0)), dimension(num_dims) :: avg_vel - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dx - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dy - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dz + real(wp), dimension(num_dims) :: avg_vel + real(wp), dimension(num_dims) :: dvel_avg_dx + real(wp), dimension(num_dims) :: dvel_avg_dy + real(wp), dimension(num_dims) :: dvel_avg_dz ! Viscous stress tensor - real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re + real(wp), dimension(num_dims, num_dims) :: tau_Re ! Generic loop iterators integer :: i, j, k, l @@ -3086,7 +3086,7 @@ contains dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) - tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & + tau_Re(1, 1) = (4._wp/3._wp)*dvel_avg_dx(1)/ & Re_avg_rsx_vf(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & @@ -3150,8 +3150,8 @@ contains dvel_avg_dx(2) = 5d-1*(dvelL_dx_vf(2)%sf(j, k, l) & + dvelR_dx_vf(2)%sf(j + 1, k, l)) - tau_Re(1, 1) = -(2d0/3d0)*(dvel_avg_dy(2) + & - avg_vel(2)/y_cc(k))/ & + tau_Re(1, 1) = -(2._wp/3._wp)*(dvel_avg_dy(2) + & + avg_vel(2)/y_cc(k))/ & Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & @@ -3221,7 +3221,7 @@ contains dvel_avg_dx(3) = 5d-1*(dvelL_dx_vf(3)%sf(j, k, l) & + dvelR_dx_vf(3)%sf(j + 1, k, l)) - tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/y_cc(k)/ & + tau_Re(1, 1) = -(2._wp/3._wp)*dvel_avg_dz(3)/y_cc(k)/ & Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1)/y_cc(k) + dvel_avg_dx(3))/ & @@ -3302,10 +3302,10 @@ contains tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsy_vf(k, j, l, 1) - tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - - 2d0*dvel_avg_dx(1) & - - 2d0*avg_vel(2)/y_cb(k))/ & - (3d0*Re_avg_rsy_vf(k, j, l, 1)) + tau_Re(2, 2) = (4._wp*dvel_avg_dy(2) & + - 2._wp*dvel_avg_dx(1) & + - 2._wp*avg_vel(2)/y_cb(k))/ & + (3._wp*Re_avg_rsy_vf(k, j, l, 1)) !$acc loop seq do i = 1, 2 @@ -3380,7 +3380,7 @@ contains dvel_avg_dy(3) = 5d-1*(dvelL_dy_vf(3)%sf(j, k, l) & + dvelR_dy_vf(3)%sf(j, k + 1, l)) - tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/y_cb(k)/ & + tau_Re(2, 2) = -(2._wp/3._wp)*dvel_avg_dz(3)/y_cb(k)/ & Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 3) = ((dvel_avg_dz(2) - avg_vel(3))/ & @@ -3477,11 +3477,11 @@ contains Re_avg_rsz_vf(l, k, j, 1)/ & y_cc(k) - tau_Re(3, 3) = (4d0*dvel_avg_dz(3)/y_cc(k) & - - 2d0*dvel_avg_dx(1) & - - 2d0*dvel_avg_dy(2) & - + 4d0*avg_vel(2)/y_cc(k))/ & - (3d0*Re_avg_rsz_vf(l, k, j, 1))/ & + tau_Re(3, 3) = (4._wp*dvel_avg_dz(3)/y_cc(k) & + - 2._wp*dvel_avg_dx(1) & + - 2._wp*dvel_avg_dy(2) & + + 4._wp*avg_vel(2)/y_cc(k))/ & + (3._wp*Re_avg_rsz_vf(l, k, j, 1))/ & y_cc(k) !$acc loop seq @@ -3590,11 +3590,11 @@ contains ! Arithmetic mean of the left and right, WENO-reconstructed, cell- ! boundary values of cell-average first-order spatial derivatives ! of velocity - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dx - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dy - real(kind(0d0)), dimension(num_dims) :: dvel_avg_dz + real(wp), dimension(num_dims) :: dvel_avg_dx + real(wp), dimension(num_dims) :: dvel_avg_dy + real(wp), dimension(num_dims) :: dvel_avg_dz - real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re !< Viscous stress tensor + real(wp), dimension(num_dims, num_dims) :: tau_Re !< Viscous stress tensor integer :: i, j, k, l !< Generic loop iterators @@ -3610,7 +3610,7 @@ contains dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) - tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & + tau_Re(1, 1) = (4._wp/3._wp)*dvel_avg_dx(1)/ & Re_avg_rsx_vf(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & @@ -3671,7 +3671,7 @@ contains dvel_avg_dx(2) = 5d-1*(dvelL_dx_vf(2)%sf(j, k, l) & + dvelR_dx_vf(2)%sf(j + 1, k, l)) - tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dy(2)/ & + tau_Re(1, 1) = -(2._wp/3._wp)*dvel_avg_dy(2)/ & Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & @@ -3740,7 +3740,7 @@ contains dvel_avg_dx(3) = 5d-1*(dvelL_dx_vf(3)%sf(j, k, l) & + dvelR_dx_vf(3)%sf(j + 1, k, l)) - tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/ & + tau_Re(1, 1) = -(2._wp/3._wp)*dvel_avg_dz(3)/ & Re_avg_rsx_vf(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1) + dvel_avg_dx(3))/ & @@ -3816,9 +3816,9 @@ contains tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsy_vf(k, j, l, 1) - tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - - 2d0*dvel_avg_dx(1))/ & - (3d0*Re_avg_rsy_vf(k, j, l, 1)) + tau_Re(2, 2) = (4._wp*dvel_avg_dy(2) & + - 2._wp*dvel_avg_dx(1))/ & + (3._wp*Re_avg_rsy_vf(k, j, l, 1)) !$acc loop seq do i = 1, 2 @@ -3886,7 +3886,7 @@ contains dvel_avg_dy(3) = 5d-1*(dvelL_dy_vf(3)%sf(j, k, l) & + dvelR_dy_vf(3)%sf(j, k + 1, l)) - tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/ & + tau_Re(2, 2) = -(2._wp/3._wp)*dvel_avg_dz(3)/ & Re_avg_rsy_vf(k, j, l, 1) tau_Re(2, 3) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & @@ -3974,10 +3974,10 @@ contains tau_Re(3, 2) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & Re_avg_rsz_vf(l, k, j, 1) - tau_Re(3, 3) = (4d0*dvel_avg_dz(3) & - - 2d0*dvel_avg_dx(1) & - - 2d0*dvel_avg_dy(2))/ & - (3d0*Re_avg_rsz_vf(l, k, j, 1)) + tau_Re(3, 3) = (4._wp*dvel_avg_dz(3) & + - 2._wp*dvel_avg_dx(1) & + - 2._wp*dvel_avg_dy(2))/ & + (3._wp*Re_avg_rsz_vf(l, k, j, 1)) !$acc loop seq do i = 1, 3 diff --git a/src/simulation/m_sim_helpers.f90 b/src/simulation/m_sim_helpers.f90 index eca90a32e7..30f05fded3 100644 --- a/src/simulation/m_sim_helpers.f90 +++ b/src/simulation/m_sim_helpers.f90 @@ -33,11 +33,11 @@ module m_sim_helpers subroutine s_compute_enthalpy(q_prim_vf, pres, rho, gamma, pi_inf, Re, H, alpha, vel, vel_sum, j, k, l) !$acc routine seq type(scalar_field), dimension(sys_size) :: q_prim_vf - real(kind(0d0)), dimension(num_fluids) :: alpha_rho - real(kind(0d0)), dimension(num_fluids) :: alpha - real(kind(0d0)), dimension(num_dims) :: vel - real(kind(0d0)) :: rho, gamma, pi_inf, qv, vel_sum, E, H, pres - real(kind(0d0)), dimension(2) :: Re + real(wp), dimension(num_fluids) :: alpha_rho + real(wp), dimension(num_fluids) :: alpha + real(wp), dimension(num_dims) :: vel + real(wp) :: rho, gamma, pi_inf, qv, vel_sum, E, H, pres + real(wp), dimension(2) :: Re integer :: i, j, k, l do i = 1, num_fluids @@ -55,9 +55,9 @@ subroutine s_compute_enthalpy(q_prim_vf, pres, rho, gamma, pi_inf, Re, H, alpha, vel(i) = q_prim_vf(contxe + i)%sf(j, k, l) end do - vel_sum = 0d0 + vel_sum = 0._wp do i = 1, num_dims - vel_sum = vel_sum + vel(i)**2d0 + vel_sum = vel_sum + vel(i)**2._wp end do pres = q_prim_vf(E_idx)%sf(j, k, l) @@ -80,22 +80,22 @@ end subroutine s_compute_enthalpy !! @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) !$acc routine seq - real(kind(0d0)), dimension(num_dims) :: vel - real(kind(0d0)) :: c, icfl_dt, vcfl_dt, rho - real(kind(0d0)), dimension(0:m, 0:n, 0:p) :: icfl_sf - real(kind(0d0)), dimension(0:m, 0:n, 0:p), optional :: vcfl_sf, Rc_sf - real(kind(0d0)) :: fltr_dtheta !< + real(wp), dimension(num_dims) :: vel + real(wp) :: c, icfl_dt, vcfl_dt, rho + real(wp), dimension(0:m, 0:n, 0:p) :: icfl_sf + real(wp), dimension(0:m, 0:n, 0:p), optional :: vcfl_sf, Rc_sf + real(wp) :: fltr_dtheta !< !! Modified dtheta accounting for Fourier filtering in azimuthal direction. integer :: j, k, l integer :: Nfq - real(kind(0d0)), dimension(2) :: Re_l + real(wp), dimension(2) :: Re_l if (grid_geometry == 3) then if (k == 0) then - fltr_dtheta = 2d0*pi*y_cb(0)/3d0 + fltr_dtheta = 2._wp*pi*y_cb(0)/3._wp elseif (k <= fourier_rings) then - Nfq = min(floor(2d0*real(k, kind(0d0))*pi), (p + 1)/2 + 1) - fltr_dtheta = 2d0*pi*y_cb(k - 1)/real(Nfq, kind(0d0)) + 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 fltr_dtheta = y_cb(k - 1)*dz(l) end if @@ -117,20 +117,20 @@ subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl if (grid_geometry == 3) then vcfl_sf(j, k, l) = maxval(dt/Re_l/rho) & - /min(dx(j), dy(k), fltr_dtheta)**2d0 + /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(1d0/Re_l) + /maxval(1._wp/Re_l) else vcfl_sf(j, k, l) = maxval(dt/Re_l/rho) & - /min(dx(j), dy(k), dz(l))**2d0 + /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(1d0/Re_l) + /maxval(1._wp/Re_l) end if end if @@ -142,11 +142,11 @@ subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl if (any(Re_size > 0)) then - vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k))**2d0 + 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(1d0/Re_l) + /maxval(1._wp/Re_l) end if @@ -156,9 +156,9 @@ subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl if (any(Re_size > 0)) then - vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/dx(j)**2d0 + 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(1d0/Re_l) + Rc_sf(j, k, l) = dx(j)*(abs(vel(1)) + c)/maxval(1._wp/Re_l) end if @@ -176,21 +176,21 @@ end subroutine s_compute_stability_from_dt !! @param l z coordinate subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) !$acc routine seq - real(kind(0d0)), dimension(num_dims) :: vel - real(kind(0d0)) :: c, icfl_dt, vcfl_dt, rho - real(kind(0d0)), dimension(0:m, 0:n, 0:p) :: max_dt - real(kind(0d0)) :: fltr_dtheta !< + real(wp), dimension(num_dims) :: vel + real(wp) :: c, icfl_dt, vcfl_dt, rho + real(wp), dimension(0:m, 0:n, 0:p) :: max_dt + real(wp) :: fltr_dtheta !< !! Modified dtheta accounting for Fourier filtering in azimuthal direction. integer :: j, k, l integer :: Nfq - real(kind(0d0)), dimension(2) :: Re_l + real(wp), dimension(2) :: Re_l if (grid_geometry == 3) then if (k == 0) then - fltr_dtheta = 2d0*pi*y_cb(0)/3d0 + fltr_dtheta = 2._wp*pi*y_cb(0)/3._wp elseif (k <= fourier_rings) then - Nfq = min(floor(2d0*real(k, kind(0d0))*pi), (p + 1)/2 + 1) - fltr_dtheta = 2d0*pi*y_cb(k - 1)/real(Nfq, kind(0d0)) + 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 fltr_dtheta = y_cb(k - 1)*dz(l) end if @@ -210,10 +210,10 @@ subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) if (any(Re_size > 0)) then if (grid_geometry == 3) then - vcfl_dt = cfl_target*(min(dx(j), dy(k), fltr_dtheta)**2d0) & + vcfl_dt = cfl_target*(min(dx(j), dy(k), fltr_dtheta)**2._wp) & /minval(1/(rho*Re_l)) else - vcfl_dt = cfl_target*(min(dx(j), dy(k), dz(l))**2d0) & + vcfl_dt = cfl_target*(min(dx(j), dy(k), dz(l))**2._wp) & /minval(1/(rho*Re_l)) end if end if @@ -224,7 +224,7 @@ subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) dy(k)/(abs(vel(2)) + c)) if (any(Re_size > 0)) then - vcfl_dt = cfl_target*(min(dx(j), dy(k))**2d0)/maxval((1/Re_l)/rho) + vcfl_dt = cfl_target*(min(dx(j), dy(k))**2._wp)/maxval((1/Re_l)/rho) end if else @@ -232,7 +232,7 @@ subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) icfl_dt = cfl_target*(dx(j)/(abs(vel(1)) + c)) if (any(Re_size > 0)) then - vcfl_dt = cfl_target*(dx(j)**2d0)/minval(1/(rho*Re_l)) + vcfl_dt = cfl_target*(dx(j)**2._wp)/minval(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 bee897b58f..d8e2797fcf 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -285,7 +285,7 @@ contains end if dx(0:m) = x_cb(0:m) - x_cb(-1:m - 1) - x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2d0 + x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2._wp if (ib) then do i = 1, num_ibs @@ -314,7 +314,7 @@ contains 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)/2d0 + y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp end if ! ================================================================== @@ -337,7 +337,7 @@ contains 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)/2d0 + z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if ! ================================================================== @@ -460,7 +460,7 @@ contains #ifdef MFC_MPI - real(kind(0d0)), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status @@ -488,7 +488,7 @@ contains if (file_exist) then data_size = m_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, x_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -499,7 +499,7 @@ contains ! 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)/2d0 + x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2._wp if (ib) then do i = 1, num_ibs @@ -519,7 +519,7 @@ contains if (file_exist) then data_size = n_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, y_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -530,7 +530,7 @@ contains ! 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)/2d0 + 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 @@ -540,7 +540,7 @@ contains if (file_exist) then data_size = p_glb + 2 call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - call MPI_FILE_READ(ifile, z_cb_glb, data_size, MPI_DOUBLE_PRECISION, status, ierr) + 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...') @@ -551,7 +551,7 @@ contains ! 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)/2d0 + z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if end if @@ -586,8 +586,8 @@ contains 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -598,7 +598,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do !Read pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then @@ -606,7 +606,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if else @@ -614,7 +614,7 @@ contains var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -679,8 +679,8 @@ contains 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) - WP_MOK = int(8d0, MPI_OFFSET_KIND) - MOK = int(1d0, MPI_OFFSET_KIND) + WP_MOK = int(8._wp, MPI_OFFSET_KIND) + MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) @@ -692,10 +692,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do !Read pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then @@ -704,10 +704,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if else @@ -717,10 +717,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_DATA%view(i), & + 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_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end do end if @@ -778,10 +778,10 @@ contains ! Initial displacement to skip at beginning of file disp = 0 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(1), & + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_airfoil_IB_DATA%view(1), & 'native', mpi_info_int, ierr) call MPI_FILE_READ(ifile, MPI_IO_airfoil_IB_DATA%var(1:Np), 3*Np, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end if @@ -795,10 +795,10 @@ contains ! Initial displacement to skip at beginning of file disp = 0 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_DOUBLE_PRECISION, MPI_IO_airfoil_IB_DATA%view(2), & + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_airfoil_IB_DATA%view(2), & 'native', mpi_info_int, ierr) call MPI_FILE_READ(ifile, MPI_IO_airfoil_IB_DATA%var(Np + 1:2*Np), 3*Np, & - MPI_DOUBLE_PRECISION, status, ierr) + mpi_p, status, ierr) end if do i = 1, Np @@ -859,7 +859,7 @@ contains ! Computing the cell-center locations buffer, at the beginning of ! the coordinate direction, from the cell-width distribution buffer do i = 1, buff_size - x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2d0 + x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2._wp end do ! Populating the cell-width distribution buffer, at the end of the @@ -890,7 +890,7 @@ contains ! Populating the cell-center locations buffer, at the end of the ! coordinate direction, from buffer of the cell-width distribution do i = 1, buff_size - x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2d0 + 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 ======================== @@ -927,7 +927,7 @@ contains ! Computing the cell-center locations buffer, at the beginning of ! the coordinate direction, from the cell-width distribution buffer do i = 1, buff_size - y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2d0 + y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp end do ! Populating the cell-width distribution buffer, at the end of the @@ -958,7 +958,7 @@ contains ! Populating the cell-center locations buffer, at the end of the ! coordinate direction, from buffer of the cell-width distribution do i = 1, buff_size - y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2d0 + 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 ======================== @@ -995,7 +995,7 @@ contains ! Computing the cell-center locations buffer, at the beginning of ! the coordinate direction, from the cell-width distribution buffer do i = 1, buff_size - z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2d0 + z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2._wp end do ! Populating the cell-width distribution buffer, at the end of the @@ -1026,7 +1026,7 @@ contains ! Populating the cell-center locations buffer, at the end of the ! coordinate direction, from buffer of the cell-width distribution do i = 1, buff_size - z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2d0 + 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 ======================== @@ -1042,13 +1042,13 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: v_vf - real(kind(0d0)) :: rho - real(kind(0d0)) :: dyn_pres - real(kind(0d0)) :: gamma - real(kind(0d0)) :: pi_inf - real(kind(0d0)) :: qv - real(kind(0d0)), dimension(2) :: Re - real(kind(0d0)) :: pres + 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 integer :: i, j, k, l, c @@ -1060,7 +1060,7 @@ contains call s_convert_to_mixture_variables(v_vf, j, k, l, rho, gamma, pi_inf, qv, Re) - dyn_pres = 0d0 + dyn_pres = 0._wp do i = mom_idx%beg, mom_idx%end dyn_pres = dyn_pres + 5d-1*v_vf(i)%sf(j, k, l)*v_vf(i)%sf(j, k, l) & /max(rho, sgm_eps) @@ -1072,7 +1072,7 @@ contains end do end if - call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0d0, & + call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0._wp, & dyn_pres, pi_inf, gamma, rho, qv, rhoYks, pres) do i = 1, num_fluids @@ -1089,15 +1089,15 @@ contains subroutine s_perform_time_step(t_step, time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, file_exists, start, finish, nt) integer, intent(inout) :: t_step - real(kind(0d0)), intent(inout) :: time_avg, time_final - real(kind(0d0)), intent(inout) :: io_time_avg, io_time_final - real(kind(0d0)), dimension(:), intent(inout) :: proc_time - real(kind(0d0)), dimension(:), intent(inout) :: io_proc_time + 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(kind(0d0)), intent(inout) :: start, finish + real(wp), intent(inout) :: start, finish integer, intent(inout) :: nt - real(kind(0d0)) :: dt_init + real(wp) :: dt_init integer :: i, j, k, l @@ -1120,7 +1120,7 @@ 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"")', & - int(ceiling(100d0*(mytime/t_stop))), & + int(ceiling(100._wp*(mytime/t_stop))), & mytime, & dt, & t_step @@ -1128,7 +1128,7 @@ contains 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 = "I0"")', & - int(ceiling(100d0*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + 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 @@ -1175,15 +1175,15 @@ contains subroutine s_save_performance_metrics(t_step, time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, file_exists, start, finish, nt) integer, intent(inout) :: t_step - real(kind(0d0)), intent(inout) :: time_avg, time_final - real(kind(0d0)), intent(inout) :: io_time_avg, io_time_final - real(kind(0d0)), dimension(:), intent(inout) :: proc_time - real(kind(0d0)), dimension(:), intent(inout) :: io_proc_time + 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(kind(0d0)), intent(inout) :: start, finish + real(wp), intent(inout) :: start, finish integer, intent(inout) :: nt - real(kind(0d0)) :: grind_time + real(wp) :: grind_time call s_mpi_barrier() @@ -1194,8 +1194,8 @@ contains end if if (proc_rank == 0) then - time_final = 0d0 - io_time_final = 0d0 + time_final = 0._wp + io_time_final = 0._wp if (num_procs == 1) then time_final = time_avg io_time_final = io_time_avg @@ -1236,7 +1236,7 @@ contains subroutine s_save_data(t_step, start, finish, io_time_avg, nt) integer, intent(inout) :: t_step - real(kind(0d0)), intent(inout) :: start, finish, io_time_avg + real(wp), intent(inout) :: start, finish, io_time_avg integer, intent(inout) :: nt integer :: i, j, k, l @@ -1300,9 +1300,9 @@ contains end if !Initialize pb based on surface tension for qbmm (polytropic) if (qbmm .and. polytropic .and. (.not. f_is_default(Web))) then - pb0 = pref + 2d0*fluid_pp(1)%ss/(R0*R0ref) + pb0 = pref + 2._wp*fluid_pp(1)%ss/(R0*R0ref) pb0 = pb0/pref - pref = 1d0 + pref = 1._wp end if #if defined(MFC_OpenACC) && defined(MFC_MEMORY_DUMP) @@ -1389,7 +1389,7 @@ contains subroutine s_initialize_mpi_domain integer :: ierr #ifdef MFC_OpenACC - real(kind(0d0)) :: starttime, endtime + real(wp) :: starttime, endtime integer :: num_devices, local_size, num_nodes, ppn, my_device_num integer :: dev, devNum, local_rank #ifdef MFC_MPI diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 2e9ca8fedf..ddeb9faaeb 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -40,12 +40,12 @@ module m_surface_tension #endif #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:,:,:,:), gL_x, gL_y, gL_z, gR_x, gR_y, gR_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:,:,:,:), gL_x, gL_y, gL_z, gR_x, gR_y, gR_z) !$acc declare link(gL_x, gL_y, gL_z, gR_x, gR_y, gR_z) #else !> @name cell boundary reconstructed gradient components and magnitude !> @{ - real(kind(0d0)), 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 !> @} !$acc declare create(gL_x, gR_x, gL_y, gR_y, gL_z, gR_z) #endif @@ -92,18 +92,18 @@ contains id, isx, isy, isz) type(scalar_field), dimension(sys_size) :: q_prim_vf !> unused so unsure what intent to give it - real(kind(0d0)), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf - real(kind(0d0)), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf - real(kind(0d0)), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_src_vf integer, intent(in) :: id type(int_bounds_info), intent(in) :: isx, isy, isz - real(kind(0d0)), dimension(num_dims, num_dims) :: Omega - real(kind(0d0)) :: w1L, w1R, w2L, w2R, w3L, w3R, w1, w2, w3 - real(kind(0d0)) :: normWL, normWR, normW + real(wp), dimension(num_dims, num_dims) :: Omega + real(wp) :: w1L, w1R, w2L, w2R, w3L, w3R, w1, w2, w3 + real(wp) :: normWL, normWR, normW if (id == 1) then !$acc parallel loop collapse(3) gang vector default(present) private(Omega, & @@ -114,21 +114,21 @@ contains w1L = gL_x(j, k, l, 1) w2L = gL_x(j, k, l, 2) - w3L = 0d0 + w3L = 0._wp if (p > 0) w3L = gL_x(j, k, l, 3) w1R = gR_x(j + 1, k, l, 1) w2R = gR_x(j + 1, k, l, 2) - w3R = 0d0 + w3R = 0._wp if (p > 0) w3R = gR_x(j + 1, k, l, 3) normWL = gL_x(j, k, l, num_dims + 1) normWR = gR_x(j + 1, k, l, num_dims + 1) - w1 = (w1L + w1R)/2d0 - w2 = (w2L + w2R)/2d0 - w3 = (w3L + w3R)/2d0 - normW = (normWL + normWR)/2d0 + w1 = (w1L + w1R)/2._wp + w2 = (w2L + w2R)/2._wp + w3 = (w3L + w3R)/2._wp + normW = (normWL + normWR)/2._wp if (normW > capillary_cutoff) then @:compute_capilary_stress_tensor() @@ -160,21 +160,21 @@ contains w1L = gL_y(k, j, l, 1) w2L = gL_y(k, j, l, 2) - w3L = 0d0 + w3L = 0._wp if (p > 0) w3L = gL_y(k, j, l, 3) w1R = gR_y(k + 1, j, l, 1) w2R = gR_y(k + 1, j, l, 2) - w3R = 0d0 + w3R = 0._wp if (p > 0) w3R = gR_y(k + 1, j, l, 3) normWL = gL_y(k, j, l, num_dims + 1) normWR = gR_y(k + 1, j, l, num_dims + 1) - w1 = (w1L + w1R)/2d0 - w2 = (w2L + w2R)/2d0 - w3 = (w3L + w3R)/2d0 - normW = (normWL + normWR)/2d0 + w1 = (w1L + w1R)/2._wp + w2 = (w2L + w2R)/2._wp + w3 = (w3L + w3R)/2._wp + normW = (normWL + normWR)/2._wp if (normW > capillary_cutoff) then @:compute_capilary_stress_tensor() @@ -206,21 +206,21 @@ contains w1L = gL_z(l, k, j, 1) w2L = gL_z(l, k, j, 2) - w3L = 0d0 + w3L = 0._wp if (p > 0) w3L = gL_z(l, k, j, 3) w1R = gR_z(l + 1, k, j, 1) w2R = gR_z(l + 1, k, j, 2) - w3R = 0d0 + w3R = 0._wp if (p > 0) w3R = gR_z(l + 1, k, j, 3) normWL = gL_z(l, k, j, num_dims + 1) normWR = gR_z(l + 1, k, j, num_dims + 1) - w1 = (w1L + w1R)/2d0 - w2 = (w2L + w2R)/2d0 - w3 = (w3L + w3R)/2d0 - normW = (normWL + normWR)/2d0 + w1 = (w1L + w1R)/2._wp + w2 = (w2L + w2R)/2._wp + w3 = (w3L + w3R)/2._wp + normW = (normWL + normWR)/2._wp if (normW > capillary_cutoff) then @:compute_capilary_stress_tensor() @@ -263,7 +263,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(1)%sf(j, k, l) = 1d0/(x_cc(j + 1) - x_cc(j - 1))* & + 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 @@ -273,7 +273,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(2)%sf(j, k, l) = 1d0/(y_cc(k + 1) - y_cc(k - 1))* & + 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 @@ -284,7 +284,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(3)%sf(j, k, l) = 1d0/(z_cc(l + 1) - z_cc(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 @@ -295,12 +295,12 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(num_dims + 1)%sf(j, k, l) = 0d0 + c_divs(num_dims + 1)%sf(j, k, l) = 0._wp !s$acc loop 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)**2d0 + 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)) @@ -324,8 +324,8 @@ contains type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z - real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z + real(wp), dimension(startx:, starty:, startz:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z + real(wp), dimension(startx:, starty:, startz:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the WENO reconstruction diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 865f3f3646..f5b65be4a0 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -57,11 +57,11 @@ module m_time_steppers @:CRAY_DECLARE_GLOBAL(type(vector_field), dimension(:), q_prim_ts) !! Cell-average primitive variables at consecutive TIMESTEPS - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :, :), rhs_pb) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :, :), rhs_pb) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :, :), rhs_mv) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :, :), rhs_mv) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension( :, :, :), max_dt) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension( :, :, :), max_dt) integer, private :: num_ts !< !! Number of time stages in the time-stepping scheme @@ -80,11 +80,11 @@ module m_time_steppers type(vector_field), allocatable, dimension(:) :: q_prim_ts !< !! Cell-average primitive variables at consecutive TIMESTEPS - real(kind(0d0)), allocatable, dimension(:, :, :, :, :) :: rhs_pb + real(wp), allocatable, dimension(:, :, :, :, :) :: rhs_pb - real(kind(0d0)), allocatable, dimension(:, :, :, :, :) :: rhs_mv + real(wp), allocatable, dimension(:, :, :, :, :) :: rhs_mv - real(kind(0d0)), allocatable, dimension(:, :, :) :: max_dt + real(wp), allocatable, dimension(:, :, :) :: max_dt integer, private :: num_ts !< !! Number of time stages in the time-stepping scheme @@ -318,14 +318,14 @@ contains subroutine s_1st_order_tvd_rk(t_step, time_avg) integer, intent(in) :: t_step - real(kind(0d0)), intent(inout) :: time_avg + real(wp), intent(inout) :: time_avg integer :: i, j, k, l, q!< Generic loop iterator - real(kind(0d0)) :: nR3bar - real(kind(0d0)) :: e_mix + real(wp) :: nR3bar + real(wp) :: e_mix - real(kind(0d0)) :: T - real(kind(0d0)), dimension(num_species) :: Ys + real(wp) :: T + real(wp), dimension(num_species) :: Ys ! Stage 1 of 1 ===================================================== @@ -432,11 +432,11 @@ contains subroutine s_2nd_order_tvd_rk(t_step, time_avg) integer, intent(in) :: t_step - real(kind(0d0)), intent(inout) :: time_avg + real(wp), intent(inout) :: time_avg integer :: i, j, k, l, q!< Generic loop iterator - real(kind(0d0)) :: start, finish - real(kind(0d0)) :: nR3bar + real(wp) :: start, finish + real(wp) :: nR3bar ! Stage 1 of 2 ===================================================== @@ -541,7 +541,7 @@ contains q_cons_ts(1)%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) & - + dt*rhs_vf(i)%sf(j, k, l))/2d0 + + dt*rhs_vf(i)%sf(j, k, l))/2._wp end do end do end do @@ -557,7 +557,7 @@ contains pb_ts(1)%sf(j, k, l, q, i) = & (pb_ts(1)%sf(j, k, l, q, i) & + pb_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_pb(j, k, l, q, i))/2d0 + + dt*rhs_pb(j, k, l, q, i))/2._wp end do end do end do @@ -575,7 +575,7 @@ contains mv_ts(1)%sf(j, k, l, q, i) = & (mv_ts(1)%sf(j, k, l, q, i) & + mv_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_mv(j, k, l, q, i))/2d0 + + dt*rhs_mv(j, k, l, q, i))/2._wp end do end do end do @@ -584,7 +584,7 @@ contains end if call nvtxStartRange("body_forces") - if (bodyForces) call s_apply_bodyforces(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, 2d0*dt/3d0) + if (bodyForces) call s_apply_bodyforces(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, 2._wp*dt/3._wp) call nvtxEndRange if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(1)%vf) @@ -615,12 +615,12 @@ contains subroutine s_3rd_order_tvd_rk(t_step, time_avg) ! -------------------------------- integer, intent(IN) :: t_step - real(kind(0d0)), intent(INOUT) :: time_avg + real(wp), intent(INOUT) :: time_avg integer :: i, j, k, l, q !< Generic loop iterator - real(kind(0d0)) :: ts_error, denom, error_fraction, time_step_factor !< Generic loop iterator - real(kind(0d0)) :: start, finish - real(kind(0d0)) :: nR3bar + real(wp) :: ts_error, denom, error_fraction, time_step_factor !< Generic loop iterator + real(wp) :: start, finish + real(wp) :: nR3bar ! Stage 1 of 3 ===================================================== @@ -724,9 +724,9 @@ contains do k = 0, n do j = 0, m q_cons_ts(2)%vf(i)%sf(j, k, l) = & - (3d0*q_cons_ts(1)%vf(i)%sf(j, k, l) & + (3._wp*q_cons_ts(1)%vf(i)%sf(j, k, l) & + q_cons_ts(2)%vf(i)%sf(j, k, l) & - + dt*rhs_vf(i)%sf(j, k, l))/4d0 + + dt*rhs_vf(i)%sf(j, k, l))/4._wp end do end do end do @@ -740,9 +740,9 @@ contains do j = 0, m do q = 1, nnode pb_ts(2)%sf(j, k, l, q, i) = & - (3d0*pb_ts(1)%sf(j, k, l, q, i) & + (3._wp*pb_ts(1)%sf(j, k, l, q, i) & + pb_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_pb(j, k, l, q, i))/4d0 + + dt*rhs_pb(j, k, l, q, i))/4._wp end do end do end do @@ -758,9 +758,9 @@ contains do j = 0, m do q = 1, nnode mv_ts(2)%sf(j, k, l, q, i) = & - (3d0*mv_ts(1)%sf(j, k, l, q, i) & + (3._wp*mv_ts(1)%sf(j, k, l, q, i) & + mv_ts(2)%sf(j, k, l, q, i) & - + dt*rhs_mv(j, k, l, q, i))/4d0 + + dt*rhs_mv(j, k, l, q, i))/4._wp end do end do end do @@ -769,7 +769,7 @@ contains end if call nvtxStartRange("body_forces") - if (bodyForces) call s_apply_bodyforces(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, dt/4d0) + if (bodyForces) call s_apply_bodyforces(q_cons_ts(2)%vf, q_prim_vf, rhs_vf, dt/4._wp) call nvtxEndRange if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(2)%vf) @@ -799,8 +799,8 @@ contains do j = 0, m q_cons_ts(1)%vf(i)%sf(j, k, l) = & (q_cons_ts(1)%vf(i)%sf(j, k, l) & - + 2d0*q_cons_ts(2)%vf(i)%sf(j, k, l) & - + 2d0*dt*rhs_vf(i)%sf(j, k, l))/3d0 + + 2._wp*q_cons_ts(2)%vf(i)%sf(j, k, l) & + + 2._wp*dt*rhs_vf(i)%sf(j, k, l))/3._wp end do end do end do @@ -815,8 +815,8 @@ contains do q = 1, nnode pb_ts(1)%sf(j, k, l, q, i) = & (pb_ts(1)%sf(j, k, l, q, i) & - + 2d0*pb_ts(2)%sf(j, k, l, q, i) & - + 2d0*dt*rhs_pb(j, k, l, q, i))/3d0 + + 2._wp*pb_ts(2)%sf(j, k, l, q, i) & + + 2._wp*dt*rhs_pb(j, k, l, q, i))/3._wp end do end do end do @@ -833,8 +833,8 @@ contains do q = 1, nnode mv_ts(1)%sf(j, k, l, q, i) = & (mv_ts(1)%sf(j, k, l, q, i) & - + 2d0*mv_ts(2)%sf(j, k, l, q, i) & - + 2d0*dt*rhs_mv(j, k, l, q, i))/3d0 + + 2._wp*mv_ts(2)%sf(j, k, l, q, i) & + + 2._wp*dt*rhs_mv(j, k, l, q, i))/3._wp end do end do end do @@ -843,7 +843,7 @@ contains end if call nvtxStartRange("body_forces") - if (bodyForces) call s_apply_bodyforces(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, 2d0*dt/3d0) + if (bodyForces) call s_apply_bodyforces(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, 2._wp*dt/3._wp) call nvtxEndRange if (grid_geometry == 3) call s_apply_fourier_filter(q_cons_ts(1)%vf) @@ -879,10 +879,10 @@ contains subroutine s_strang_splitting(t_step, time_avg) integer, intent(in) :: t_step - real(kind(0d0)), intent(inout) :: time_avg + real(wp), intent(inout) :: time_avg integer :: i, j, k, l !< Generic loop iterator - real(kind(0d0)) :: start, finish + real(wp) :: start, finish call cpu_time(start) @@ -934,18 +934,18 @@ contains subroutine s_compute_dt() - real(kind(0d0)) :: rho !< Cell-avg. density - real(kind(0d0)), dimension(num_dims) :: vel !< Cell-avg. velocity - real(kind(0d0)) :: vel_sum !< Cell-avg. velocity sum - real(kind(0d0)) :: pres !< Cell-avg. pressure - real(kind(0d0)), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction - real(kind(0d0)) :: gamma !< Cell-avg. sp. heat ratio - real(kind(0d0)) :: pi_inf !< Cell-avg. liquid stiffness function - real(kind(0d0)) :: c !< Cell-avg. sound speed - real(kind(0d0)) :: H !< Cell-avg. enthalpy - real(kind(0d0)), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp) :: rho !< Cell-avg. density + real(wp), dimension(num_dims) :: vel !< Cell-avg. velocity + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + 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(kind(0d0)) :: dt_local + real(wp) :: dt_local type(int_bounds_info) :: ix, iy, iz integer :: i, j, k, l, q !< Generic loop iterators @@ -994,7 +994,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(1:sys_size), intent(inout) :: rhs_vf - real(kind(0d0)), intent(in) :: ldt !< local dt + real(wp), intent(in) :: ldt !< local dt integer :: i, j, k, l diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index c8c83f6b4f..6056ee157f 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -29,10 +29,10 @@ module m_viscous !$acc declare create(is1_viscous, is2_viscous, is3_viscous, iv) #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), Res_viscous) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), Res_viscous) !$acc declare link(Res_viscous) #else - real(kind(0d0)), allocatable, dimension(:, :) :: Res_viscous + real(wp), allocatable, dimension(:, :) :: Res_viscous !$acc declare create(Re_viscous) #endif @@ -81,11 +81,11 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: tau_Re_vf type(int_bounds_info), intent(in) :: ix, iy, iz - real(kind(0d0)) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables - real(kind(0d0)), dimension(2) :: Re_visc - real(kind(0d0)), dimension(num_fluids) :: alpha_visc, alpha_rho_visc + real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(wp), dimension(2) :: Re_visc + real(wp), dimension(num_fluids) :: alpha_visc, alpha_rho_visc - real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re + real(wp), dimension(num_dims, num_dims) :: tau_Re integer :: i, j, k, l, q !< Generic loop iterator @@ -99,7 +99,7 @@ contains do j = is1_viscous%beg, is1_viscous%end !$acc loop seq do i = momxb, E_idx - tau_Re_vf(i)%sf(j, k, l) = 0d0 + tau_Re_vf(i)%sf(j, k, l) = 0._wp end do end do end do @@ -114,16 +114,16 @@ contains do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then - alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) + alpha_visc(i) = 1._wp - q_prim_vf(E_idx + i)%sf(j, k, l) else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then !$acc loop seq @@ -145,17 +145,17 @@ contains pi_inf_visc = pi_infs(1) end if else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp - alpha_visc_sum = 0d0 + alpha_visc_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_rho_visc(i) = max(0._wp, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0._wp, alpha_visc(i)), 1._wp) alpha_visc_sum = alpha_visc_sum + alpha_visc(i) end do @@ -175,14 +175,14 @@ contains do i = 1, 2 Re_visc(i) = dflt_real - if (Re_size(i) > 0) Re_visc(i) = 0d0 + if (Re_size(i) > 0) Re_visc(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & + Re_visc(i) end do - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) end do end if @@ -192,10 +192,10 @@ contains grad_x_vf(2)%sf(j, k, l))/ & Re_visc(1) - tau_Re(2, 2) = (4d0*grad_y_vf(2)%sf(j, k, l) & - - 2d0*grad_x_vf(1)%sf(j, k, l) & - - 2d0*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & - (3d0*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)) !$acc loop seq do i = 1, 2 tau_Re_vf(contxe + i)%sf(j, k, l) = & @@ -221,16 +221,16 @@ contains do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then - alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) + alpha_visc(i) = 1._wp - q_prim_vf(E_idx + i)%sf(j, k, l) else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then !$acc loop seq @@ -252,17 +252,17 @@ contains pi_inf_visc = pi_infs(1) end if else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp - alpha_visc_sum = 0d0 + alpha_visc_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_rho_visc(i) = max(0._wp, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0._wp, alpha_visc(i)), 1._wp) alpha_visc_sum = alpha_visc_sum + alpha_visc(i) end do @@ -282,14 +282,14 @@ contains do i = 1, 2 Re_visc(i) = dflt_real - if (Re_size(i) > 0) Re_visc(i) = 0d0 + if (Re_size(i) > 0) Re_visc(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & + Re_visc(i) end do - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) end do end if @@ -325,16 +325,16 @@ contains do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then - alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) + alpha_visc(i) = 1._wp - q_prim_vf(E_idx + i)%sf(j, k, l) else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then !$acc loop seq @@ -356,17 +356,17 @@ contains pi_inf_visc = pi_infs(1) end if else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp - alpha_visc_sum = 0d0 + alpha_visc_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_rho_visc(i) = max(0._wp, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0._wp, alpha_visc(i)), 1._wp) alpha_visc_sum = alpha_visc_sum + alpha_visc(i) end do @@ -386,20 +386,20 @@ contains do i = 1, 2 Re_visc(i) = dflt_real - if (Re_size(i) > 0) Re_visc(i) = 0d0 + if (Re_size(i) > 0) Re_visc(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & + Re_visc(i) end do - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) end do end if end if - tau_Re(2, 2) = -(2d0/3d0)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & + 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) - & @@ -433,16 +433,16 @@ contains do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) if (bubbles .and. num_fluids == 1) then - alpha_visc(i) = 1d0 - q_prim_vf(E_idx + i)%sf(j, k, l) + alpha_visc(i) = 1._wp - q_prim_vf(E_idx + i)%sf(j, k, l) else alpha_visc(i) = q_prim_vf(E_idx + i)%sf(j, k, l) end if end do if (bubbles) then - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then !$acc loop seq @@ -464,17 +464,17 @@ contains pi_inf_visc = pi_infs(1) end if else - rho_visc = 0d0 - gamma_visc = 0d0 - pi_inf_visc = 0d0 + rho_visc = 0._wp + gamma_visc = 0._wp + pi_inf_visc = 0._wp - alpha_visc_sum = 0d0 + alpha_visc_sum = 0._wp if (mpp_lim) then !$acc loop seq do i = 1, num_fluids - alpha_rho_visc(i) = max(0d0, alpha_rho_visc(i)) - alpha_visc(i) = min(max(0d0, alpha_visc(i)), 1d0) + alpha_rho_visc(i) = max(0._wp, alpha_rho_visc(i)) + alpha_visc(i) = min(max(0._wp, alpha_visc(i)), 1._wp) alpha_visc_sum = alpha_visc_sum + alpha_visc(i) end do @@ -494,14 +494,14 @@ contains do i = 1, 2 Re_visc(i) = dflt_real - if (Re_size(i) > 0) Re_visc(i) = 0d0 + if (Re_size(i) > 0) Re_visc(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & + Re_visc(i) end do - Re_visc(i) = 1d0/max(Re_visc(i), sgm_eps) + Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) end do end if @@ -538,7 +538,7 @@ contains dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, & ix, iy, iz) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), & + real(wp), dimension(startx:, starty:, startz:, 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 @@ -987,7 +987,7 @@ contains 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(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + real(wp), dimension(startx:, starty:, startz:, 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 @@ -1085,7 +1085,7 @@ contains norm_dir, vL_prim_vf, vR_prim_vf, ix, iy, iz) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + real(wp), dimension(startx:, starty:, startz:, 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 @@ -1208,7 +1208,7 @@ contains integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz, iv_in integer, intent(in) :: dim, buff_size_in - real(kind(0d0)), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL + real(wp), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL integer :: i, j, k, l !< Generic loop iterators @@ -1235,7 +1235,7 @@ contains !$acc loop seq do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = & - 1d0/((1d0 + wa_flg)*dL(j)) & + 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) & @@ -1263,7 +1263,7 @@ contains !$acc loop seq do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = & - 1d0/((1d0 + wa_flg)*dL(k)) & + 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) & @@ -1291,7 +1291,7 @@ contains !$acc loop seq do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = & - 1d0/((1d0 + wa_flg)*dL(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) & @@ -1397,10 +1397,10 @@ contains do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end grad_x%sf(is1_viscous%beg, k, l) = & - (-3d0*var%sf(is1_viscous%beg, k, l) + 4d0*var%sf(is1_viscous%beg + 1, k, l) - var%sf(is1_viscous%beg + 2, k, l))/ & + (-3._wp*var%sf(is1_viscous%beg, k, l) + 4._wp*var%sf(is1_viscous%beg + 1, k, l) - var%sf(is1_viscous%beg + 2, k, l))/ & (x_cc(is1_viscous%beg + 2) - x_cc(is1_viscous%beg)) grad_x%sf(is1_viscous%end, k, l) = & - (3d0*var%sf(is1_viscous%end, k, l) - 4d0*var%sf(is1_viscous%end - 1, k, l) + var%sf(is1_viscous%end - 2, k, l))/ & + (3._wp*var%sf(is1_viscous%end, k, l) - 4._wp*var%sf(is1_viscous%end - 1, k, l) + var%sf(is1_viscous%end - 2, k, l))/ & (x_cc(is1_viscous%end) - x_cc(is1_viscous%end - 2)) end do end do @@ -1409,10 +1409,10 @@ contains do l = is3_viscous%beg, is3_viscous%end do j = is1_viscous%beg, is1_viscous%end grad_y%sf(j, is2_viscous%beg, l) = & - (-3d0*var%sf(j, is2_viscous%beg, l) + 4d0*var%sf(j, is2_viscous%beg + 1, l) - var%sf(j, is2_viscous%beg + 2, l))/ & + (-3._wp*var%sf(j, is2_viscous%beg, l) + 4._wp*var%sf(j, is2_viscous%beg + 1, l) - var%sf(j, is2_viscous%beg + 2, l))/ & (y_cc(is2_viscous%beg + 2) - y_cc(is2_viscous%beg)) grad_y%sf(j, is2_viscous%end, l) = & - (3d0*var%sf(j, is2_viscous%end, l) - 4d0*var%sf(j, is2_viscous%end - 1, l) + var%sf(j, is2_viscous%end - 2, l))/ & + (3._wp*var%sf(j, is2_viscous%end, l) - 4._wp*var%sf(j, is2_viscous%end - 1, l) + var%sf(j, is2_viscous%end - 2, l))/ & (y_cc(is2_viscous%end) - y_cc(is2_viscous%end - 2)) end do end do @@ -1421,10 +1421,10 @@ contains do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end grad_z%sf(j, k, is3_viscous%beg) = & - (-3d0*var%sf(j, k, is3_viscous%beg) + 4d0*var%sf(j, k, is3_viscous%beg + 1) - var%sf(j, k, is3_viscous%beg + 2))/ & + (-3._wp*var%sf(j, k, is3_viscous%beg) + 4._wp*var%sf(j, k, is3_viscous%beg + 1) - var%sf(j, k, is3_viscous%beg + 2))/ & (z_cc(is3_viscous%beg + 2) - z_cc(is3_viscous%beg)) grad_z%sf(j, k, is3_viscous%end) = & - (3d0*var%sf(j, k, is3_viscous%end) - 4d0*var%sf(j, k, is3_viscous%end - 1) + var%sf(j, k, is3_viscous%end - 2))/ & + (3._wp*var%sf(j, k, is3_viscous%end) - 4._wp*var%sf(j, k, is3_viscous%end - 1) + var%sf(j, k, is3_viscous%end - 2))/ & (z_cc(is3_viscous%end) - z_cc(is3_viscous%end - 2)) end do end do @@ -1435,7 +1435,7 @@ contains !$acc parallel loop collapse(2) gang vector default(present) do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end - grad_x%sf(0, k, l) = (-3d0*var%sf(0, k, l) + 4d0*var%sf(1, k, l) - var%sf(2, k, l))/ & + 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 @@ -1444,7 +1444,7 @@ contains !$acc parallel loop collapse(2) gang vector default(present) do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end - grad_x%sf(m, k, l) = (3d0*var%sf(m, k, l) - 4d0*var%sf(m - 1, k, l) + var%sf(m - 2, k, l))/ & + 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 @@ -1454,7 +1454,7 @@ contains !$acc parallel loop collapse(2) gang vector default(present) do l = is3_viscous%beg, is3_viscous%end do j = is1_viscous%beg, is1_viscous%end - grad_y%sf(j, 0, l) = (-3d0*var%sf(j, 0, l) + 4d0*var%sf(j, 1, l) - var%sf(j, 2, l))/ & + 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 @@ -1463,7 +1463,7 @@ contains !$acc parallel loop collapse(2) gang vector default(present) do l = is3_viscous%beg, is3_viscous%end do j = is1_viscous%beg, is1_viscous%end - grad_y%sf(j, n, l) = (3d0*var%sf(j, n, l) - 4d0*var%sf(j, n - 1, l) + var%sf(j, n - 2, l))/ & + 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 @@ -1474,7 +1474,7 @@ contains do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end grad_z%sf(j, k, 0) = & - (-3d0*var%sf(j, k, 0) + 4d0*var%sf(j, k, 1) - var%sf(j, k, 2))/ & + (-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 @@ -1484,7 +1484,7 @@ contains do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end grad_z%sf(j, k, p) = & - (3d0*var%sf(j, k, p) - 4d0*var%sf(j, k, p - 1) + var%sf(j, k, p - 2))/ & + (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 diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 6a05b9d9c3..02997fddc2 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -45,10 +45,10 @@ module m_weno !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :, :), v_rs_ws_x, v_rs_ws_y, v_rs_ws_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :, :), v_rs_ws_x, v_rs_ws_y, v_rs_ws_z) !$acc declare link(v_rs_ws_x, v_rs_ws_y, v_rs_ws_z) #else - real(kind(0d0)), 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 #endif !> @} @@ -61,27 +61,27 @@ module m_weno !! dimension denotes the cell-location in the relevant coordinate direction. !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbL_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbL_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbL_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbL_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbL_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbL_z) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbR_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbR_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), poly_coef_cbR_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbR_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbR_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), poly_coef_cbR_z) !$acc declare link(poly_coef_cbL_x, poly_coef_cbL_y, poly_coef_cbL_z) !$acc declare link(poly_coef_cbR_x, poly_coef_cbR_y, poly_coef_cbR_z) #else - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_x - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_y - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_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(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_x - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_y - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_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 #endif - ! real(kind(0d0)), pointer, dimension(:, :, :) :: poly_coef_L => null() - ! real(kind(0d0)), pointer, dimension(:, :, :) :: poly_coef_R => null() + ! real(wp), pointer, dimension(:, :, :) :: poly_coef_L => null() + ! real(wp), pointer, dimension(:, :, :) :: poly_coef_R => null() !> @} !> @name The ideal weights at the left and the right cell-boundaries and at the @@ -90,25 +90,25 @@ module m_weno !! last denotes the cell-location in the relevant coordinate direction. !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbL_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbL_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbL_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbL_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbL_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbL_z) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbR_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbR_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :), d_cbR_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbR_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbR_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :), d_cbR_z) !$acc declare link(d_cbL_x, d_cbL_y, d_cbL_z, d_cbR_x, d_cbR_y, d_cbR_z) #else - real(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbL_x - real(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbL_y - real(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbL_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(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbR_x - real(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbR_y - real(kind(0d0)), target, allocatable, dimension(:, :) :: d_cbR_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 #endif -! real(kind(0d0)), pointer, dimension(:, :) :: d_L => null() -! real(kind(0d0)), pointer, dimension(:, :) :: d_R => null() +! real(wp), pointer, dimension(:, :) :: d_L => null() +! real(wp), pointer, dimension(:, :) :: d_R => null() !> @} !> @name Smoothness indicator coefficients in the x-, y-, and z-directions. Note @@ -117,16 +117,16 @@ module m_weno !! the cell-location in the relevant coordinate direction. !> @{ #ifdef CRAY_ACC_WAR - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), beta_coef_x) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), beta_coef_y) - @:CRAY_DECLARE_GLOBAL(real(kind(0d0)), dimension(:, :, :), beta_coef_z) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), beta_coef_x) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), beta_coef_y) + @:CRAY_DECLARE_GLOBAL(real(wp), dimension(:, :, :), beta_coef_z) !$acc declare link(beta_coef_x, beta_coef_y, beta_coef_z) #else - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: beta_coef_x - real(kind(0d0)), target, allocatable, dimension(:, :, :) :: beta_coef_y - real(kind(0d0)), 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 #endif -! real(kind(0d0)), pointer, dimension(:, :, :) :: beta_coef => null() +! real(wp), pointer, dimension(:, :, :) :: beta_coef => null() !> @} ! END: WENO Coefficients =================================================== @@ -142,7 +142,7 @@ module m_weno ! !> @} - real(kind(0d0)) :: test + real(wp) :: test !$acc declare create(test) #ifndef CRAY_ACC_WAR @@ -271,7 +271,7 @@ contains type(int_bounds_info), intent(in) :: is integer :: s - real(kind(0d0)), pointer, dimension(:) :: s_cb => null() !< + 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 @@ -308,13 +308,13 @@ contains 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) = 1d0 - d_cbR_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (1, i + 1) = 1d0 - d_cbL_${XYZ}$ (0, i + 1) + 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) = 4d0*(s_cb(i) - s_cb(i + 1))**2d0/ & - (s_cb(i) - s_cb(i + 2))**2d0 - beta_coef_${XYZ}$ (i + 1, 1, 0) = 4d0*(s_cb(i) - s_cb(i + 1))**2d0/ & - (s_cb(i - 1) - s_cb(i + 1))**2d0 + 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 @@ -324,13 +324,13 @@ contains ! the WENO reconstruction if (null_weights) then if (bc_s%beg == -4) then - d_cbR_${XYZ}$ (1, 0) = 0d0; d_cbR_${XYZ}$ (0, 0) = 1d0 - d_cbL_${XYZ}$ (1, 0) = 0d0; d_cbL_${XYZ}$ (0, 0) = 1d0 + d_cbR_${XYZ}$ (1, 0) = 0._wp; d_cbR_${XYZ}$ (0, 0) = 1._wp + d_cbL_${XYZ}$ (1, 0) = 0._wp; d_cbL_${XYZ}$ (0, 0) = 1._wp end if if (bc_s%end == -4) then - d_cbR_${XYZ}$ (0, s) = 0d0; d_cbR_${XYZ}$ (1, s) = 1d0 - d_cbL_${XYZ}$ (0, s) = 0d0; d_cbL_${XYZ}$ (1, s) = 1d0 + d_cbR_${XYZ}$ (0, s) = 0._wp; d_cbR_${XYZ}$ (1, s) = 1._wp + d_cbL_${XYZ}$ (0, s) = 0._wp; d_cbL_${XYZ}$ (1, s) = 1._wp end if end if ! END: Computing WENO3 Coefficients ================================ @@ -395,72 +395,72 @@ contains ((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) = 1d0 - d_cbR_${XYZ}$ (0, i + 1) - d_cbR_${XYZ}$ (2, i + 1) - d_cbL_${XYZ}$ (1, i + 1) = 1d0 - d_cbL_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (2, i + 1) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/((s_cb(i) - & - s_cb(i + 3))**2d0*(s_cb(i + 1) - s_cb(i + 3))**2d0) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(19d0*(s_cb(i + 1) - & - s_cb(i))**2d0 - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - & - s_cb(i + 1)) + 2d0*(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))**2d0*(s_cb(i + 3) - & - s_cb(i + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + (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)))**2d0)/((s_cb(i) - & - s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 3))**2d0) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + (s_cb(i) - s_cb(i - 1))**2d0 + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - & - s_cb(i + 2))**2d0*(s_cb(i) - s_cb(i + 2))**2d0) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*((s_cb(i) - & - s_cb(i + 1))*((s_cb(i) - s_cb(i - 1)) + 20d0*(s_cb(i + 1) - & - s_cb(i))) + (2d0*(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))**2d0*(s_cb(i + 2) - & - s_cb(i))) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2d0)/ & - ((s_cb(i - 1) - s_cb(i + 1))**2d0*(s_cb(i - 1) - & - s_cb(i + 2))**2d0) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(12d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - & - s_cb(i - 1)))**2d0 + 3d0*((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))**2d0*(s_cb(i - 1) - & - s_cb(i + 1))**2d0) + 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(19d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - & - s_cb(i + 1))) + 2d0*(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))**2d0*(s_cb(i + 1) - & - s_cb(i - 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) = & - 4d0*(s_cb(i) - s_cb(i + 1))**2d0*(10d0*(s_cb(i + 1) - & - s_cb(i))**2d0 + (s_cb(i) - s_cb(i - 1))**2d0 + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - & - s_cb(i))**2d0*(s_cb(i - 2) - s_cb(i + 1))**2d0) + 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 @@ -470,17 +470,17 @@ contains ! the WENO reconstruction if (null_weights) then if (bc_s%beg == -4) then - d_cbR_${XYZ}$ (1:2, 0) = 0d0; d_cbR_${XYZ}$ (0, 0) = 1d0 - d_cbL_${XYZ}$ (1:2, 0) = 0d0; d_cbL_${XYZ}$ (0, 0) = 1d0 - d_cbR_${XYZ}$ (2, 1) = 0d0; d_cbR_${XYZ}$ (:, 1) = d_cbR_${XYZ}$ (:, 1)/sum(d_cbR_${XYZ}$ (:, 1)) - d_cbL_${XYZ}$ (2, 1) = 0d0; 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 == -4) then - d_cbR_${XYZ}$ (0, s - 1) = 0d0; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) - d_cbL_${XYZ}$ (0, s - 1) = 0d0; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) - d_cbR_${XYZ}$ (0:1, s) = 0d0; d_cbR_${XYZ}$ (2, s) = 1d0 - d_cbL_${XYZ}$ (0:1, s) = 0d0; d_cbL_${XYZ}$ (2, s) = 1d0 + 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 end if @@ -507,22 +507,22 @@ contains is1_weno_d, is2_weno_d, is3_weno_d) type(scalar_field), dimension(1:), intent(in) :: v_vf - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z + real(wp), dimension(startx:, starty:, startz:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: norm_dir integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d - real(kind(0d0)), dimension(-weno_polyn:weno_polyn - 1) :: dvd - real(kind(0d0)), dimension(0:weno_polyn) :: poly - real(kind(0d0)), dimension(0:weno_polyn) :: alpha - real(kind(0d0)), dimension(0:weno_polyn) :: omega - real(kind(0d0)), dimension(0:weno_polyn) :: beta - real(kind(0d0)), dimension(0:weno_polyn) :: delta - real(kind(0d0)) :: tau5 - real(kind(0d0)), pointer :: beta_p(:) + real(wp), dimension(-weno_polyn:weno_polyn - 1) :: dvd + real(wp), dimension(0:weno_polyn) :: poly + real(wp), dimension(0:weno_polyn) :: alpha + real(wp), dimension(0:weno_polyn) :: omega + real(wp), dimension(0:weno_polyn) :: beta + real(wp), dimension(0:weno_polyn) :: delta + real(wp) :: tau5 + real(wp), pointer :: beta_p(:) - real(kind(0d0)) :: v_rs1, v_rs2, v_rs3, v_rs4, v_rs5 + real(wp) :: v_rs1, v_rs2, v_rs3, v_rs4, v_rs5 integer :: i, j, k, l, r, s, w @@ -611,13 +611,13 @@ contains elseif (mapped_weno) then alpha = d_cbL_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbL_${XYZ}$ (:, j)*(1d0 + d_cbL_${XYZ}$ (:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_${XYZ}$ (:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_${XYZ}$ (:, j)))) + alpha = (d_cbL_${XYZ}$ (:, j)*(1._wp + d_cbL_${XYZ}$ (:, j) - 3._wp*omega) + omega**2._wp) & + *(omega/(d_cbL_${XYZ}$ (:, j)**2._wp + omega*(1._wp - 2._wp*d_cbL_${XYZ}$ (:, j)))) elseif (wenoz) then ! Borges, et al. (2008) tau5 = abs(beta(1) - beta(0)) - alpha = d_cbL_${XYZ}$ (:, j)*(1d0 + tau5/beta) + alpha = d_cbL_${XYZ}$ (:, j)*(1._wp + tau5/beta) end if @@ -638,11 +638,11 @@ contains elseif (mapped_weno) then alpha = d_cbR_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbR_${XYZ}$ (:, j)*(1d0 + d_cbR_${XYZ}$ (:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_${XYZ}$ (:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_${XYZ}$ (:, j)))) + alpha = (d_cbR_${XYZ}$ (:, j)*(1._wp + d_cbR_${XYZ}$ (:, j) - 3._wp*omega) + omega**2._wp) & + *(omega/(d_cbR_${XYZ}$ (:, j)**2._wp + omega*(1._wp - 2._wp*d_cbR_${XYZ}$ (:, j)))) elseif (wenoz) then - alpha = d_cbR_${XYZ}$ (:, j)*(1d0 + tau5/beta) + alpha = d_cbR_${XYZ}$ (:, j)*(1._wp + tau5/beta) end if @@ -706,21 +706,21 @@ contains elseif (mapped_weno) then alpha = d_cbL_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbL_${XYZ}$ (:, j)*(1d0 + d_cbL_${XYZ}$ (:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbL_${XYZ}$ (:, j)**2d0 + omega*(1d0 - 2d0*d_cbL_${XYZ}$ (:, j)))) + alpha = (d_cbL_${XYZ}$ (:, j)*(1._wp + d_cbL_${XYZ}$ (:, j) - 3._wp*omega) + omega**2._wp) & + *(omega/(d_cbL_${XYZ}$ (:, j)**2._wp + omega*(1._wp - 2._wp*d_cbL_${XYZ}$ (:, j)))) elseif (wenoz) then ! Borges, et al. (2008) tau5 = abs(beta(2) - beta(0)) ! Equation 25 - alpha = d_cbL_${XYZ}$ (:, j)*(1d0 + tau5/beta) ! Equation 28 (note: weno_eps was already added to beta) + alpha = d_cbL_${XYZ}$ (:, j)*(1._wp + tau5/beta) ! Equation 28 (note: weno_eps was already added to beta) elseif (teno) then ! Fu, et al. (2016) ! Fu's code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 tau5 = abs(beta(2) - beta(0)) - alpha = (1d0 + tau5/beta)**6d0 ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) + alpha = (1._wp + tau5/beta)**6._wp ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) - delta = merge(0d0, 1d0, omega < teno_CT) ! Equation 26 + delta = merge(0._wp, 1._wp, omega < teno_CT) ! Equation 26 alpha = delta*d_cbL_${XYZ}$ (:, j) ! Equation 27 end if @@ -747,11 +747,11 @@ contains elseif (mapped_weno) then alpha = d_cbR_${XYZ}$ (:, j)/(beta*beta) omega = alpha/sum(alpha) - alpha = (d_cbR_${XYZ}$ (:, j)*(1d0 + d_cbR_${XYZ}$ (:, j) - 3d0*omega) + omega**2d0) & - *(omega/(d_cbR_${XYZ}$ (:, j)**2d0 + omega*(1d0 - 2d0*d_cbR_${XYZ}$ (:, j)))) + alpha = (d_cbR_${XYZ}$ (:, j)*(1._wp + d_cbR_${XYZ}$ (:, j) - 3._wp*omega) + omega**2._wp) & + *(omega/(d_cbR_${XYZ}$ (:, j)**2._wp + omega*(1._wp - 2._wp*d_cbR_${XYZ}$ (:, j)))) elseif (wenoz) then - alpha = d_cbR_${XYZ}$ (:, j)*(1d0 + tau5/beta) + alpha = d_cbR_${XYZ}$ (:, j)*(1._wp + tau5/beta) elseif (teno) then alpha = delta*d_cbR_${XYZ}$ (:, j) @@ -913,37 +913,37 @@ contains !! @param l Third-coordinate cell index subroutine s_preserve_monotonicity(v_rs_ws, vL_rs_vf, vR_rs_vf) - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(IN) :: v_rs_ws - real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_rs_vf, vR_rs_vf + real(wp), dimension(startx:, starty:, startz:, 1:), intent(IN) :: v_rs_ws + real(wp), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: vL_rs_vf, vR_rs_vf integer :: i, j, k, l - real(kind(0d0)), dimension(-1:1) :: d !< Curvature measures at the zone centers + real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers - real(kind(0d0)) :: d_MD, d_LC !< + 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(kind(0d0)) :: vL_UL, vR_UL - real(kind(0d0)) :: vL_MD, vR_MD - real(kind(0d0)) :: vL_LC, vR_LC - real(kind(0d0)) :: vL_min, vR_min - real(kind(0d0)) :: vL_max, vR_max + real(wp) :: vL_UL, vR_UL + real(wp) :: vL_MD, vR_MD + real(wp) :: vL_LC, vR_LC + real(wp) :: vL_min, vR_min + real(wp) :: vL_max, vR_max - real(kind(0d0)), parameter :: alpha = 2d0 !> + 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(kind(0d0)), parameter :: beta = 4d0/3d0 !< + 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. - real(kind(0d0)), parameter :: alpha_mp = 2d0 - real(kind(0d0)), parameter :: beta_mp = 4d0/3d0 + real(wp), parameter :: alpha_mp = 2._wp + real(wp), parameter :: beta_mp = 4._wp/3._wp !$acc parallel loop gang vector collapse (4) default(present) private(d) do l = is3_weno%beg, is3_weno%end @@ -953,27 +953,27 @@ contains 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) & - *2d0 + *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) & - *2d0 + *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) & - *2d0 + *2._wp - d_MD = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 + 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(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 + 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) & @@ -1012,27 +1012,27 @@ contains 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) & - *2d0 + *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) & - *2d0 + *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) & - *2d0 - - d_MD = (sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, 4d0*d(1) - d(0))) & - *abs((sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(0))) & - *(sign(1d0, 4d0*d(0) - d(1)) + sign(1d0, d(1)))) & - *min(abs(4d0*d(0) - d(1)), abs(d(0)), & - abs(4d0*d(1) - d(0)), abs(d(1)))/8d0 - - d_LC = (sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, 4d0*d(0) - d(-1))) & - *abs((sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(-1))) & - *(sign(1d0, 4d0*d(-1) - d(0)) + sign(1d0, d(0)))) & - *min(abs(4d0*d(-1) - d(0)), abs(d(-1)), & - abs(4d0*d(0) - d(-1)), abs(d(0)))/8d0 + *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) & diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 091538073e..b167e42c64 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -26,12 +26,12 @@ program p_main implicit none integer :: t_step !< Iterator for the time-stepping loop - real(kind(0d0)) :: time_avg, time_final - real(kind(0d0)) :: io_time_avg, io_time_final - real(kind(0d0)), allocatable, dimension(:) :: proc_time - real(kind(0d0)), allocatable, dimension(:) :: io_proc_time + 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(kind(0d0)) :: start, finish + real(wp) :: start, finish integer :: nt call system_clock(COUNT=cpu_start, COUNT_RATE=cpu_rate) @@ -54,7 +54,7 @@ program p_main else t_step = t_step_start if (t_step == 0) then - mytime = 0d0 + mytime = 0._wp else mytime = t_step*dt end if