From 109ef34e70866010f2635c0a503fb8bf42f77286 Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:26:04 -0700 Subject: [PATCH 1/7] Modifying beta storage in common to account for particle arrays. --- src/common/m_boundary_common.fpp | 28 +++-- src/common/m_boundary_primitives.fpp | 171 +++++++++++++++------------ src/common/m_mpi_common.fpp | 81 ++++++++----- 3 files changed, 161 insertions(+), 119 deletions(-) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index f407bdbcf1..71914ddbfc 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -65,7 +65,7 @@ contains end do end if - if (bubbles_lagrange) then + if (bubbles_lagrange .or. particles_lagrange) then beta_bc_bounds(1)%beg = -mapcells - 1 beta_bc_bounds(1)%end = m + mapcells + 1 ! n > 0 always for bubbles_lagrange @@ -456,34 +456,35 @@ contains end subroutine s_finalize_boundary_common_module !> Populate ghost cell buffers of the Lagrangian-bubble beta (void fraction) variables based on the boundary conditions. - impure subroutine s_populate_beta_buffers(q_beta, kahan_comp, bc_type, nvar) + impure subroutine s_populate_beta_buffers(q_beta, kahan_comp, bc_type, nvar, vars_comm) type(scalar_field), dimension(:), intent(inout) :: q_beta type(scalar_field), dimension(:), intent(inout) :: kahan_comp type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type integer, intent(in) :: nvar + integer, dimension(:), intent(in) :: vars_comm - call s_populate_beta_bc_direction(1, -1, bc%x, bc_type(1, 1), q_beta, kahan_comp, nvar) - call s_populate_beta_bc_direction(1, 1, bc%x, bc_type(1, 2), q_beta, kahan_comp, nvar) + call s_populate_beta_bc_direction(1, -1, bc%x, bc_type(1, 1), q_beta, kahan_comp, nvar, vars_comm) + call s_populate_beta_bc_direction(1, 1, bc%x, bc_type(1, 2), q_beta, kahan_comp, nvar, vars_comm) ! n > 0 always for bubbles_lagrange #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - call s_populate_beta_bc_direction(2, -1, bc%y, bc_type(2, 1), q_beta, kahan_comp, nvar) - call s_populate_beta_bc_direction(2, 1, bc%y, bc_type(2, 2), q_beta, kahan_comp, nvar) + call s_populate_beta_bc_direction(2, -1, bc%y, bc_type(2, 1), q_beta, kahan_comp, nvar, vars_comm) + call s_populate_beta_bc_direction(2, 1, bc%y, bc_type(2, 2), q_beta, kahan_comp, nvar, vars_comm) #:endif if (p == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - call s_populate_beta_bc_direction(3, -1, bc%z, bc_type(3, 1), q_beta, kahan_comp, nvar) - call s_populate_beta_bc_direction(3, 1, bc%z, bc_type(3, 2), q_beta, kahan_comp, nvar) + call s_populate_beta_bc_direction(3, -1, bc%z, bc_type(3, 1), q_beta, kahan_comp, nvar, vars_comm) + call s_populate_beta_bc_direction(3, 1, bc%z, bc_type(3, 2), q_beta, kahan_comp, nvar, vars_comm) #:endif end subroutine s_populate_beta_buffers !> Populate beta variable buffers for one direction and location, by dispatching the per-cell beta BC routines over the boundary !! face and performing the paired MPI reduction for processor boundaries. - impure subroutine s_populate_beta_bc_direction(bc_dir, bc_loc, bc_bounds, bc_type_edge, q_beta, kahan_comp, nvar) + impure subroutine s_populate_beta_bc_direction(bc_dir, bc_loc, bc_bounds, bc_type_edge, q_beta, kahan_comp, nvar, vars_comm) integer, intent(in) :: bc_dir, bc_loc type(int_bounds_info), intent(in) :: bc_bounds @@ -492,6 +493,7 @@ contains type(scalar_field), dimension(:), intent(inout) :: kahan_comp integer, intent(in) :: nvar integer :: bc_edge, k_beg, k_end, l_beg, l_end, k, l, bc_code + integer, dimension(:), intent(in) :: vars_comm if (bc_loc == -1) then bc_edge = bc_bounds%beg @@ -511,7 +513,7 @@ contains l_beg = beta_bc_bounds(2)%beg; l_end = beta_bc_bounds(2)%end end if - $:GPU_PARALLEL_LOOP(private='[l, k, bc_code]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k, bc_code]', collapse=2, copyin = '[vars_comm]') do l = l_beg, l_end do k = k_beg, k_end ! bc_type is not allocated over the beta ghost extents in x and y, so those directions dispatch on the @@ -524,9 +526,9 @@ contains select case (bc_code) case (BC_PERIODIC) - call s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar) + call s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar, vars_comm) case (BC_REFLECTIVE) - call s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar) + call s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar, vars_comm) end select end do end do @@ -536,7 +538,7 @@ contains ! The beta reduction is a paired exchange (rightward accumulate at bc_loc = -1, leftward distribute at bc_loc = 1), so it ! must run at both locations whenever either edge of the direction is a processor boundary. if (bc_bounds%beg >= 0 .or. bc_bounds%end >= 0) then - call s_mpi_reduce_beta_variables_buffers(q_beta, kahan_comp, bc_dir, bc_loc, nvar) + call s_mpi_reduce_beta_variables_buffers(q_beta, kahan_comp, bc_dir, bc_loc, nvar, vars_comm) end if end subroutine s_populate_beta_bc_direction diff --git a/src/common/m_boundary_primitives.fpp b/src/common/m_boundary_primitives.fpp index 2fce625617..966fcce39e 100644 --- a/src/common/m_boundary_primitives.fpp +++ b/src/common/m_boundary_primitives.fpp @@ -1379,7 +1379,7 @@ contains end subroutine s_F_igr_ghost_cell_extrapolation - subroutine s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar) + subroutine s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar, vars_comm) $:GPU_ROUTINE(function_name='s_beta_periodic', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta @@ -1387,65 +1387,72 @@ contains integer, intent(in) :: bc_dir, bc_loc integer, intent(in) :: k, l integer, intent(in) :: nvar - integer :: j, i + integer, dimension(:), intent(in) :: vars_comm + integer :: j, i, idx real(wp) :: y_kahan, t_kahan if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then ! bc%x%beg do i = 1, nvar + idx = vars_comm(i) do j = -mapCells - 1, mapCells ! Kahan-compensated addition of ghost to interior - y_kahan = real(q_beta(beta_vars(i))%sf(m + j + 1, k, l), & - & kind=wp) + kahan_comp(beta_vars(i))%sf(m + j + 1, k, l) - kahan_comp(beta_vars(i))%sf(j, & + y_kahan = real(q_beta(idx)%sf(m + j + 1, k, l), & + & kind=wp) + kahan_comp(idx)%sf(m + j + 1, k, l) - kahan_comp(idx)%sf(j, & & k, l) - t_kahan = real(q_beta(beta_vars(i))%sf(j, k, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(j, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j, k, l)) - y_kahan - q_beta(beta_vars(i))%sf(j, k, l) = t_kahan + t_kahan = real(q_beta(idx)%sf(j, k, l), kind=wp) + y_kahan + kahan_comp(idx)%sf(j, k, l) = (t_kahan - q_beta(idx)%sf(j, k, l)) - y_kahan + q_beta(idx)%sf(j, k, l) = t_kahan end do end do else do i = 1, nvar + idx = vars_comm(i) do j = -mapcells, mapcells + 1 - q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l) - kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l) + q_beta(idx)%sf(m + j, k, l) = q_beta(idx)%sf(j - 1, k, l) + kahan_comp(idx)%sf(m + j, k, l) = kahan_comp(idx)%sf(j - 1, k, l) end do end do end if else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc%y%beg do i = 1, nvar + idx = vars_comm(i) do j = -mapcells - 1, mapcells - y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j + 1, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, & - & n + j + 1, l) - kahan_comp(beta_vars(i))%sf(k, j, l) - t_kahan = real(q_beta(beta_vars(i))%sf(k, j, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, j, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j, l)) - y_kahan - q_beta(beta_vars(i))%sf(k, j, l) = t_kahan + y_kahan = real(q_beta(idx)%sf(k, n + j + 1, l), kind=wp) + kahan_comp(idx)%sf(k, & + & n + j + 1, l) - kahan_comp(idx)%sf(k, j, l) + t_kahan = real(q_beta(idx)%sf(k, j, l), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, j, l) = (t_kahan - q_beta(idx)%sf(k, j, l)) - y_kahan + q_beta(idx)%sf(k, j, l) = t_kahan end do end do else do i = 1, nvar + idx = vars_comm(i) do j = -mapcells, mapcells + 1 - q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l) - kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l) + q_beta(idx)%sf(k, n + j, l) = q_beta(idx)%sf(k, j - 1, l) + kahan_comp(idx)%sf(k, n + j, l) = kahan_comp(idx)%sf(k, j - 1, l) end do end do end if else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc%z%beg do i = 1, nvar + idx = vars_comm(i) do j = -mapcells - 1, mapcells - y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j + 1), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, & - & p + j + 1) - kahan_comp(beta_vars(i))%sf(k, l, j) - t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, l, j) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j)) - y_kahan - q_beta(beta_vars(i))%sf(k, l, j) = t_kahan + y_kahan = real(q_beta(idx)%sf(k, l, p + j + 1), kind=wp) + kahan_comp(idx)%sf(k, l, & + & p + j + 1) - kahan_comp(idx)%sf(k, l, j) + t_kahan = real(q_beta(idx)%sf(k, l, j), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, l, j) = (t_kahan - q_beta(idx)%sf(k, l, j)) - y_kahan + q_beta(idx)%sf(k, l, j) = t_kahan end do end do else do i = 1, nvar + idx = vars_comm(i) do j = -mapcells, mapcells + 1 - q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, j - 1) - kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1) + q_beta(idx)%sf(k, l, p + j) = q_beta(idx)%sf(k, l, j - 1) + kahan_comp(idx)%sf(k, l, p + j) = kahan_comp(idx)%sf(k, l, j - 1) end do end do end if @@ -1453,54 +1460,61 @@ contains end subroutine s_beta_periodic - subroutine s_beta_extrapolation(q_beta, bc_dir, bc_loc, k, l, nvar) + subroutine s_beta_extrapolation(q_beta, bc_dir, bc_loc, k, l, nvar, vars_comm) $:GPU_ROUTINE(function_name='s_beta_extrapolation', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta integer, intent(in) :: bc_dir, bc_loc integer, intent(in) :: k, l integer, intent(in) :: nvar - integer :: j, i + integer, dimension(:), intent(in) :: vars_comm + integer :: j, i, idx if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then ! bc%x%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(-j, k, l) = 0._wp + q_beta(idx)%sf(-j, k, l) = 0._wp end do end do else do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(m + j, k, l) = 0._wp + q_beta(idx)%sf(m + j, k, l) = 0._wp end do end do end if else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc%y%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(k, -j, l) = 0._wp + q_beta(idx)%sf(k, -j, l) = 0._wp end do end do else do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(k, n + j, l) = 0._wp + q_beta(idx)%sf(k, n + j, l) = 0._wp end do end do end if else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc%z%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(k, l, -j) = 0._wp + q_beta(idx)%sf(k, l, -j) = 0._wp end do end do else !< bc%z%end do i = 1, nvar + idx = vars_comm(i) do j = 1, buff_size - q_beta(beta_vars(i))%sf(k, l, p + j) = 0._wp + q_beta(idx)%sf(k, l, p + j) = 0._wp end do end do end if @@ -1508,7 +1522,7 @@ contains end subroutine s_beta_extrapolation - subroutine s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar) + subroutine s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar, vars_comm) $:GPU_ROUTINE(function_name='s_beta_reflective', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta @@ -1516,7 +1530,8 @@ contains integer, intent(in) :: bc_dir, bc_loc integer, intent(in) :: k, l integer, intent(in) :: nvar - integer :: j, i + integer, dimension(:), intent(in) :: vars_comm + integer :: j, i, idx real(wp) :: y_kahan, t_kahan ! Reflective BC for void fraction: 1) Fold ghost-cell contributions back onto their mirror interior cells (Kahan) 2) Set @@ -1525,93 +1540,99 @@ contains if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then ! bc%x%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(-j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(-j, k, & - & l) - kahan_comp(beta_vars(i))%sf(j - 1, k, l) - t_kahan = real(q_beta(beta_vars(i))%sf(j - 1, k, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(j - 1, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j - 1, k, l)) - y_kahan - q_beta(beta_vars(i))%sf(j - 1, k, l) = t_kahan + y_kahan = real(q_beta(idx)%sf(-j, k, l), kind=wp) + kahan_comp(idx)%sf(-j, k, & + & l) - kahan_comp(idx)%sf(j - 1, k, l) + t_kahan = real(q_beta(idx)%sf(j - 1, k, l), kind=wp) + y_kahan + kahan_comp(idx)%sf(j - 1, k, l) = (t_kahan - q_beta(idx)%sf(j - 1, k, l)) - y_kahan + q_beta(idx)%sf(j - 1, k, l) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(-j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l) - kahan_comp(beta_vars(i))%sf(-j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l) + q_beta(idx)%sf(-j, k, l) = q_beta(idx)%sf(j - 1, k, l) + kahan_comp(idx)%sf(-j, k, l) = kahan_comp(idx)%sf(j - 1, k, l) end do end do else !< bc%x%end do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(m + j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(m + j, k, & - & l) - kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l) - t_kahan = real(q_beta(beta_vars(i))%sf(m - (j - 1), k, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l) = (t_kahan - q_beta(beta_vars(i))%sf(m - (j - 1), k, & + y_kahan = real(q_beta(idx)%sf(m + j, k, l), kind=wp) + kahan_comp(idx)%sf(m + j, k, & + & l) - kahan_comp(idx)%sf(m - (j - 1), k, l) + t_kahan = real(q_beta(idx)%sf(m - (j - 1), k, l), kind=wp) + y_kahan + kahan_comp(idx)%sf(m - (j - 1), k, l) = (t_kahan - q_beta(idx)%sf(m - (j - 1), k, & & l)) - y_kahan - q_beta(beta_vars(i))%sf(m - (j - 1), k, l) = t_kahan + q_beta(idx)%sf(m - (j - 1), k, l) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(m - (j - 1), k, l) - kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l) + q_beta(idx)%sf(m + j, k, l) = q_beta(idx)%sf(m - (j - 1), k, l) + kahan_comp(idx)%sf(m + j, k, l) = kahan_comp(idx)%sf(m - (j - 1), k, l) end do end do end if else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc%y%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(k, -j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, -j, & - & l) - kahan_comp(beta_vars(i))%sf(k, j - 1, l) - t_kahan = real(q_beta(beta_vars(i))%sf(k, j - 1, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, j - 1, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j - 1, l)) - y_kahan - q_beta(beta_vars(i))%sf(k, j - 1, l) = t_kahan + y_kahan = real(q_beta(idx)%sf(k, -j, l), kind=wp) + kahan_comp(idx)%sf(k, -j, & + & l) - kahan_comp(idx)%sf(k, j - 1, l) + t_kahan = real(q_beta(idx)%sf(k, j - 1, l), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, j - 1, l) = (t_kahan - q_beta(idx)%sf(k, j - 1, l)) - y_kahan + q_beta(idx)%sf(k, j - 1, l) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(k, -j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l) - kahan_comp(beta_vars(i))%sf(k, -j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l) + q_beta(idx)%sf(k, -j, l) = q_beta(idx)%sf(k, j - 1, l) + kahan_comp(idx)%sf(k, -j, l) = kahan_comp(idx)%sf(k, j - 1, l) end do end do else !< bc%y%end do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, n + j, & - & l) - kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l) - t_kahan = real(q_beta(beta_vars(i))%sf(k, n - (j - 1), l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l) = (t_kahan - q_beta(beta_vars(i))%sf(k, n - (j - 1), & + y_kahan = real(q_beta(idx)%sf(k, n + j, l), kind=wp) + kahan_comp(idx)%sf(k, n + j, & + & l) - kahan_comp(idx)%sf(k, n - (j - 1), l) + t_kahan = real(q_beta(idx)%sf(k, n - (j - 1), l), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, n - (j - 1), l) = (t_kahan - q_beta(idx)%sf(k, n - (j - 1), & & l)) - y_kahan - q_beta(beta_vars(i))%sf(k, n - (j - 1), l) = t_kahan + q_beta(idx)%sf(k, n - (j - 1), l) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, n - (j - 1), l) - kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l) + q_beta(idx)%sf(k, n + j, l) = q_beta(idx)%sf(k, n - (j - 1), l) + kahan_comp(idx)%sf(k, n + j, l) = kahan_comp(idx)%sf(k, n - (j - 1), l) end do end do end if else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc%z%beg do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(k, l, -j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, & - & -j) - kahan_comp(beta_vars(i))%sf(k, l, j - 1) - t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j - 1), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, l, j - 1) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j - 1)) - y_kahan - q_beta(beta_vars(i))%sf(k, l, j - 1) = t_kahan + y_kahan = real(q_beta(idx)%sf(k, l, -j), kind=wp) + kahan_comp(idx)%sf(k, l, & + & -j) - kahan_comp(idx)%sf(k, l, j - 1) + t_kahan = real(q_beta(idx)%sf(k, l, j - 1), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, l, j - 1) = (t_kahan - q_beta(idx)%sf(k, l, j - 1)) - y_kahan + q_beta(idx)%sf(k, l, j - 1) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(k, l, -j) = q_beta(beta_vars(i))%sf(k, l, j - 1) - kahan_comp(beta_vars(i))%sf(k, l, -j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1) + q_beta(idx)%sf(k, l, -j) = q_beta(idx)%sf(k, l, j - 1) + kahan_comp(idx)%sf(k, l, -j) = kahan_comp(idx)%sf(k, l, j - 1) end do end do else !< bc%z%end do i = 1, nvar + idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, & - & p + j) - kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1)) - t_kahan = real(q_beta(beta_vars(i))%sf(k, l, p - (j - 1)), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, & + y_kahan = real(q_beta(idx)%sf(k, l, p + j), kind=wp) + kahan_comp(idx)%sf(k, l, & + & p + j) - kahan_comp(idx)%sf(k, l, p - (j - 1)) + t_kahan = real(q_beta(idx)%sf(k, l, p - (j - 1)), kind=wp) + y_kahan + kahan_comp(idx)%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(idx)%sf(k, l, & & p - (j - 1))) - y_kahan - q_beta(beta_vars(i))%sf(k, l, p - (j - 1)) = t_kahan + q_beta(idx)%sf(k, l, p - (j - 1)) = t_kahan end do do j = 1, mapCells + 1 - q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, p - (j - 1)) - kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1)) + q_beta(idx)%sf(k, l, p + j) = q_beta(idx)%sf(k, l, p - (j - 1)) + kahan_comp(idx)%sf(k, l, p + j) = kahan_comp(idx)%sf(k, l, p - (j - 1)) end do end do end if diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 3f6e34f6c5..c86ab491c0 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -68,6 +68,24 @@ contains halo_size = -1 + buff_size*(v_size) end if + if bubbles_lagrange .or. particles_lagrange then + beta_v_size = size(beta_vars) + beta_comm_size_1 = m + 2*mapCells + 3 + beta_comm_size_2 = merge(n + 2*mapCells + 3, 1, n>0) + beta_comm_size_3 = merge(p + 2*mapCells + 3, 1, p>0) + if (n > 0) then + if (p > 0) then + beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2*beta_comm_size_3, & + & beta_comm_size_1*beta_comm_size_3, beta_comm_size_1*beta_comm_size_2) - 1 + else + beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2, beta_comm_size_1) - 1 + end if + else + beta_helo_size = 2*(mapCells + 1)*beta_v_size - 1 + end if + halo_size = max(halo_size, beta_halo_size) + end if + $:GPU_UPDATE(device='[halo_size, v_size]') #ifndef __NVCOMPILER_GPU_UNIFIED_MEM @@ -1075,11 +1093,12 @@ contains !! @param q_cons_vf Cell-average conservative variables !! @param mpi_dir MPI communication coordinate direction !! @param pbc_loc Processor boundary condition (PBC) location - subroutine s_mpi_reduce_beta_variables_buffers(q_comm, kahan_comp, mpi_dir, pbc_loc, nVar) + subroutine s_mpi_reduce_beta_variables_buffers(q_comm, kahan_comp, mpi_dir, pbc_loc, nVar, vars_comm) type(scalar_field), dimension(1:), intent(inout) :: q_comm type(scalar_field), dimension(1:), intent(inout) :: kahan_comp integer, intent(in) :: mpi_dir, pbc_loc, nVar + integer, dimension(:), intent(in) :: vars_comm integer :: i, j, k, l, r, q !< Generic loop iterators integer :: lb_size integer :: buffer_counts(1:3), buffer_count @@ -1154,8 +1173,8 @@ contains do i = 1, v_size r = (i - 1) + v_size*((j + mapcells + 1) + lb_size*((k - comm_coords(2)%beg) + comm_size(2) & & *(l - comm_coords(3)%beg))) - buff_send(r) = real(q_comm(beta_vars(i))%sf(j + pack_offset, k, l), & - & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j + pack_offset, k, l), kind=wp) + buff_send(r) = real(q_comm(vars_comm(i))%sf(j + pack_offset, k, l), & + & kind=wp) - real(kahan_comp(vars_comm(i))%sf(j + pack_offset, k, l), kind=wp) end do end do end do @@ -1169,8 +1188,8 @@ contains do j = comm_coords(1)%beg, comm_coords(1)%end r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k + mapcells + 1) & & + lb_size*(l - comm_coords(3)%beg))) - buff_send(r) = real(q_comm(beta_vars(i))%sf(j, k + pack_offset, l), & - & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j, k + pack_offset, l), kind=wp) + buff_send(r) = real(q_comm(vars_comm)%sf(j, k + pack_offset, l), & + & kind=wp) - real(kahan_comp(vars_comm)%sf(j, k + pack_offset, l), kind=wp) end do end do end do @@ -1184,8 +1203,8 @@ contains do j = comm_coords(1)%beg, comm_coords(1)%end r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k - comm_coords(2)%beg) & & + comm_size(2)*(l + mapcells + 1))) - buff_send(r) = real(q_comm(beta_vars(i))%sf(j, k, l + pack_offset), & - & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j, k, l + pack_offset), kind=wp) + buff_send(r) = real(q_comm(vars_comm(i))%sf(j, k, l + pack_offset), & + & kind=wp) - real(kahan_comp(vars_comm(i))%sf(j, k, l + pack_offset), kind=wp) end do end do end do @@ -1246,17 +1265,17 @@ contains r = (i - 1) + v_size*((j + mapcells + 1) + lb_size*((k - comm_coords(2)%beg) & & + comm_size(2)*(l - comm_coords(3)%beg))) if (replace_buff) then - q_comm(beta_vars(i))%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp) - kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, & - & l) = real(q_comm(beta_vars(i))%sf(j + unpack_offset, k, l), & + q_comm(vars_comm(i))%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp) + kahan_comp(vars_comm(i))%sf(j + unpack_offset, k, & + & l) = real(q_comm(vars_comm(i))%sf(j + unpack_offset, k, l), & & kind=wp) - buff_recv(r) else - y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, l), & + y_kahan = buff_recv(r) - real(kahan_comp(vars_comm(i))%sf(j + unpack_offset, k, l), & & kind=wp) - t_kahan = real(q_comm(beta_vars(i))%sf(j + unpack_offset, k, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, & - & l) = (t_kahan - q_comm(beta_vars(i))%sf(j + unpack_offset, k, l)) - y_kahan - q_comm(beta_vars(i))%sf(j + unpack_offset, k, l) = t_kahan + t_kahan = real(q_comm(vars_comm(i))%sf(j + unpack_offset, k, l), kind=wp) + y_kahan + kahan_comp(vars_comm(i))%sf(j + unpack_offset, k, & + & l) = (t_kahan - q_comm(vars_comm(i))%sf(j + unpack_offset, k, l)) - y_kahan + q_comm(vars_comm(i))%sf(j + unpack_offset, k, l) = t_kahan end if end do end do @@ -1272,17 +1291,17 @@ contains r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k + mapcells + 1) & & + lb_size*(l - comm_coords(3)%beg))) if (replace_buff) then - q_comm(beta_vars(i))%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp) - kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, & - & l) = real(q_comm(beta_vars(i))%sf(j, k + unpack_offset, l), & + q_comm(vars_comm(i))%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp) + kahan_comp(vars_comm(i))%sf(j, k + unpack_offset, & + & l) = real(q_comm(vars_comm(i))%sf(j, k + unpack_offset, l), & & kind=wp) - buff_recv(r) else - y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, l), & + y_kahan = buff_recv(r) - real(kahan_comp(vars_comm(i))%sf(j, k + unpack_offset, l), & & kind=wp) - t_kahan = real(q_comm(beta_vars(i))%sf(j, k + unpack_offset, l), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, & - & l) = (t_kahan - q_comm(beta_vars(i))%sf(j, k + unpack_offset, l)) - y_kahan - q_comm(beta_vars(i))%sf(j, k + unpack_offset, l) = t_kahan + t_kahan = real(q_comm(vars_comm(i))%sf(j, k + unpack_offset, l), kind=wp) + y_kahan + kahan_comp(vars_comm(i))%sf(j, k + unpack_offset, & + & l) = (t_kahan - q_comm(vars_comm(i))%sf(j, k + unpack_offset, l)) - y_kahan + q_comm(vars_comm(i))%sf(j, k + unpack_offset, l) = t_kahan end if end do end do @@ -1298,18 +1317,18 @@ contains r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k - comm_coords(2)%beg) & & + comm_size(2)*(l + mapcells + 1))) if (replace_buff) then - q_comm(beta_vars(i))%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp) - kahan_comp(beta_vars(i))%sf(j, k, & - & l + unpack_offset) = real(q_comm(beta_vars(i))%sf(j, k, & + q_comm(vars_comm(i))%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp) + kahan_comp(vars_comm(i))%sf(j, k, & + & l + unpack_offset) = real(q_comm(vars_comm(i))%sf(j, k, & & l + unpack_offset), kind=wp) - buff_recv(r) else - y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j, k, l + unpack_offset), & + y_kahan = buff_recv(r) - real(kahan_comp(vars_comm(i))%sf(j, k, l + unpack_offset), & & kind=wp) - t_kahan = real(q_comm(beta_vars(i))%sf(j, k, l + unpack_offset), kind=wp) + y_kahan - kahan_comp(beta_vars(i))%sf(j, k, & - & l + unpack_offset) = (t_kahan - q_comm(beta_vars(i))%sf(j, k, & + t_kahan = real(q_comm(vars_comm(i))%sf(j, k, l + unpack_offset), kind=wp) + y_kahan + kahan_comp(vars_comm(i))%sf(j, k, & + & l + unpack_offset) = (t_kahan - q_comm(vars_comm(i))%sf(j, k, & & l + unpack_offset)) - y_kahan - q_comm(beta_vars(i))%sf(j, k, l + unpack_offset) = t_kahan + q_comm(vars_comm(i))%sf(j, k, l + unpack_offset) = t_kahan end if end do end do From 1e166c83a2fa44f8484e1a38b473b6e25490b65d Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:36:51 -0700 Subject: [PATCH 2/7] Adding integers for halo expansion --- src/common/m_mpi_common.fpp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index c86ab491c0..d16fe475c4 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -45,6 +45,8 @@ contains !> Initialize the module. impure subroutine s_initialize_mpi_common_module + integer :: beta_v_size, beta_comm_size_1, beta_comm_size_2, beta_comm_size_3, beta_halo_size + #ifdef MFC_MPI ! Allocating buff_send/recv and. Please note that for the sake of simplicity, both variables are provided sufficient storage ! to hold the largest buffer in the computational domain. From 5b5fe335704b3c00801eec3de11406f8725a61c2 Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:45:11 -0700 Subject: [PATCH 3/7] typos and minor changes to the MPI common module --- src/common/m_mpi_common.fpp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index d16fe475c4..5cda6b2de8 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -70,7 +70,7 @@ contains halo_size = -1 + buff_size*(v_size) end if - if bubbles_lagrange .or. particles_lagrange then + if (bubbles_lagrange .or. particles_lagrange) then beta_v_size = size(beta_vars) beta_comm_size_1 = m + 2*mapCells + 3 beta_comm_size_2 = merge(n + 2*mapCells + 3, 1, n>0) @@ -83,7 +83,7 @@ contains beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2, beta_comm_size_1) - 1 end if else - beta_helo_size = 2*(mapCells + 1)*beta_v_size - 1 + beta_halo_size = 2*(mapCells + 1)*beta_v_size - 1 end if halo_size = max(halo_size, beta_halo_size) end if @@ -1190,8 +1190,8 @@ contains do j = comm_coords(1)%beg, comm_coords(1)%end r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k + mapcells + 1) & & + lb_size*(l - comm_coords(3)%beg))) - buff_send(r) = real(q_comm(vars_comm)%sf(j, k + pack_offset, l), & - & kind=wp) - real(kahan_comp(vars_comm)%sf(j, k + pack_offset, l), kind=wp) + buff_send(r) = real(q_comm(vars_comm(i))%sf(j, k + pack_offset, l), & + & kind=wp) - real(kahan_comp(vars_comm(i))%sf(j, k + pack_offset, l), kind=wp) end do end do end do From 17877004a937e541b705490d46f774733f345090 Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:51:04 -0700 Subject: [PATCH 4/7] removing particles call until implementation of particles_lagrange --- src/common/m_mpi_common.fpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 5cda6b2de8..97bbe29274 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -70,7 +70,7 @@ contains halo_size = -1 + buff_size*(v_size) end if - if (bubbles_lagrange .or. particles_lagrange) then + if (bubbles_lagrange) then beta_v_size = size(beta_vars) beta_comm_size_1 = m + 2*mapCells + 3 beta_comm_size_2 = merge(n + 2*mapCells + 3, 1, n>0) From eb5f41518f5d3e009f14e84b505bc0fd1bb70a85 Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:52:15 -0700 Subject: [PATCH 5/7] removing particles lagrange here as well --- src/common/m_boundary_common.fpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 71914ddbfc..3f55487c11 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -65,7 +65,7 @@ contains end do end if - if (bubbles_lagrange .or. particles_lagrange) then + if (bubbles_lagrange) then beta_bc_bounds(1)%beg = -mapcells - 1 beta_bc_bounds(1)%end = m + mapcells + 1 ! n > 0 always for bubbles_lagrange From 9be23da64b80dbe03da151dee1e5b9fef32ce20f Mon Sep 17 00:00:00 2001 From: joshgillis <121623242+joshgillis@users.noreply.github.com> Date: Thu, 23 Jul 2026 14:55:49 -0700 Subject: [PATCH 6/7] adding beta_vars to bubble boundary routine calls --- src/simulation/m_bubbles_EL.fpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index a7057867bf..e013a05da6 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -872,9 +872,9 @@ contains call nvtxStartRange("BUBBLES-LAGRANGE-BETA-COMM") if (lag_params%cluster_type >= 4) then - call s_populate_beta_buffers(q_beta, kahan_comp, bc_type, 3) + call s_populate_beta_buffers(q_beta, kahan_comp, bc_type, 3, beta_vars) else - call s_populate_beta_buffers(q_beta, kahan_comp, bc_type, 2) + call s_populate_beta_buffers(q_beta, kahan_comp, bc_type, 2, beta_vars) end if call nvtxEndRange From df0a9691fbceb63caa99a8d2e1755d9f6ae64c18 Mon Sep 17 00:00:00 2001 From: Joshua Alan Gillis Date: Thu, 23 Jul 2026 21:58:20 -0700 Subject: [PATCH 7/7] formatting --- src/common/m_boundary_common.fpp | 4 ++-- src/common/m_boundary_primitives.fpp | 26 +++++++++----------- src/common/m_mpi_common.fpp | 36 ++++++++++++++-------------- 3 files changed, 31 insertions(+), 35 deletions(-) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 3f55487c11..ca0cd74e06 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -462,7 +462,7 @@ contains type(scalar_field), dimension(:), intent(inout) :: kahan_comp type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type integer, intent(in) :: nvar - integer, dimension(:), intent(in) :: vars_comm + integer, dimension(:), intent(in) :: vars_comm call s_populate_beta_bc_direction(1, -1, bc%x, bc_type(1, 1), q_beta, kahan_comp, nvar, vars_comm) call s_populate_beta_bc_direction(1, 1, bc%x, bc_type(1, 2), q_beta, kahan_comp, nvar, vars_comm) @@ -493,7 +493,7 @@ contains type(scalar_field), dimension(:), intent(inout) :: kahan_comp integer, intent(in) :: nvar integer :: bc_edge, k_beg, k_end, l_beg, l_end, k, l, bc_code - integer, dimension(:), intent(in) :: vars_comm + integer, dimension(:), intent(in) :: vars_comm if (bc_loc == -1) then bc_edge = bc_bounds%beg diff --git a/src/common/m_boundary_primitives.fpp b/src/common/m_boundary_primitives.fpp index 966fcce39e..72babc4a49 100644 --- a/src/common/m_boundary_primitives.fpp +++ b/src/common/m_boundary_primitives.fpp @@ -1397,9 +1397,8 @@ contains idx = vars_comm(i) do j = -mapCells - 1, mapCells ! Kahan-compensated addition of ghost to interior - y_kahan = real(q_beta(idx)%sf(m + j + 1, k, l), & - & kind=wp) + kahan_comp(idx)%sf(m + j + 1, k, l) - kahan_comp(idx)%sf(j, & - & k, l) + y_kahan = real(q_beta(idx)%sf(m + j + 1, k, l), kind=wp) + kahan_comp(idx)%sf(m + j + 1, k, & + & l) - kahan_comp(idx)%sf(j, k, l) t_kahan = real(q_beta(idx)%sf(j, k, l), kind=wp) + y_kahan kahan_comp(idx)%sf(j, k, l) = (t_kahan - q_beta(idx)%sf(j, k, l)) - y_kahan q_beta(idx)%sf(j, k, l) = t_kahan @@ -1419,8 +1418,8 @@ contains do i = 1, nvar idx = vars_comm(i) do j = -mapcells - 1, mapcells - y_kahan = real(q_beta(idx)%sf(k, n + j + 1, l), kind=wp) + kahan_comp(idx)%sf(k, & - & n + j + 1, l) - kahan_comp(idx)%sf(k, j, l) + y_kahan = real(q_beta(idx)%sf(k, n + j + 1, l), kind=wp) + kahan_comp(idx)%sf(k, n + j + 1, & + & l) - kahan_comp(idx)%sf(k, j, l) t_kahan = real(q_beta(idx)%sf(k, j, l), kind=wp) + y_kahan kahan_comp(idx)%sf(k, j, l) = (t_kahan - q_beta(idx)%sf(k, j, l)) - y_kahan q_beta(idx)%sf(k, j, l) = t_kahan @@ -1560,8 +1559,7 @@ contains y_kahan = real(q_beta(idx)%sf(m + j, k, l), kind=wp) + kahan_comp(idx)%sf(m + j, k, & & l) - kahan_comp(idx)%sf(m - (j - 1), k, l) t_kahan = real(q_beta(idx)%sf(m - (j - 1), k, l), kind=wp) + y_kahan - kahan_comp(idx)%sf(m - (j - 1), k, l) = (t_kahan - q_beta(idx)%sf(m - (j - 1), k, & - & l)) - y_kahan + kahan_comp(idx)%sf(m - (j - 1), k, l) = (t_kahan - q_beta(idx)%sf(m - (j - 1), k, l)) - y_kahan q_beta(idx)%sf(m - (j - 1), k, l) = t_kahan end do do j = 1, mapCells + 1 @@ -1575,8 +1573,8 @@ contains do i = 1, nvar idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(idx)%sf(k, -j, l), kind=wp) + kahan_comp(idx)%sf(k, -j, & - & l) - kahan_comp(idx)%sf(k, j - 1, l) + y_kahan = real(q_beta(idx)%sf(k, -j, l), kind=wp) + kahan_comp(idx)%sf(k, -j, l) - kahan_comp(idx)%sf(k, & + & j - 1, l) t_kahan = real(q_beta(idx)%sf(k, j - 1, l), kind=wp) + y_kahan kahan_comp(idx)%sf(k, j - 1, l) = (t_kahan - q_beta(idx)%sf(k, j - 1, l)) - y_kahan q_beta(idx)%sf(k, j - 1, l) = t_kahan @@ -1593,8 +1591,7 @@ contains y_kahan = real(q_beta(idx)%sf(k, n + j, l), kind=wp) + kahan_comp(idx)%sf(k, n + j, & & l) - kahan_comp(idx)%sf(k, n - (j - 1), l) t_kahan = real(q_beta(idx)%sf(k, n - (j - 1), l), kind=wp) + y_kahan - kahan_comp(idx)%sf(k, n - (j - 1), l) = (t_kahan - q_beta(idx)%sf(k, n - (j - 1), & - & l)) - y_kahan + kahan_comp(idx)%sf(k, n - (j - 1), l) = (t_kahan - q_beta(idx)%sf(k, n - (j - 1), l)) - y_kahan q_beta(idx)%sf(k, n - (j - 1), l) = t_kahan end do do j = 1, mapCells + 1 @@ -1608,8 +1605,8 @@ contains do i = 1, nvar idx = vars_comm(i) do j = 1, mapCells + 1 - y_kahan = real(q_beta(idx)%sf(k, l, -j), kind=wp) + kahan_comp(idx)%sf(k, l, & - & -j) - kahan_comp(idx)%sf(k, l, j - 1) + y_kahan = real(q_beta(idx)%sf(k, l, -j), kind=wp) + kahan_comp(idx)%sf(k, l, -j) - kahan_comp(idx)%sf(k, & + & l, j - 1) t_kahan = real(q_beta(idx)%sf(k, l, j - 1), kind=wp) + y_kahan kahan_comp(idx)%sf(k, l, j - 1) = (t_kahan - q_beta(idx)%sf(k, l, j - 1)) - y_kahan q_beta(idx)%sf(k, l, j - 1) = t_kahan @@ -1626,8 +1623,7 @@ contains y_kahan = real(q_beta(idx)%sf(k, l, p + j), kind=wp) + kahan_comp(idx)%sf(k, l, & & p + j) - kahan_comp(idx)%sf(k, l, p - (j - 1)) t_kahan = real(q_beta(idx)%sf(k, l, p - (j - 1)), kind=wp) + y_kahan - kahan_comp(idx)%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(idx)%sf(k, l, & - & p - (j - 1))) - y_kahan + kahan_comp(idx)%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(idx)%sf(k, l, p - (j - 1))) - y_kahan q_beta(idx)%sf(k, l, p - (j - 1)) = t_kahan end do do j = 1, mapCells + 1 diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 97bbe29274..145a72c3ea 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -45,7 +45,7 @@ contains !> Initialize the module. impure subroutine s_initialize_mpi_common_module - integer :: beta_v_size, beta_comm_size_1, beta_comm_size_2, beta_comm_size_3, beta_halo_size + integer :: beta_v_size, beta_comm_size_1, beta_comm_size_2, beta_comm_size_3, beta_halo_size #ifdef MFC_MPI ! Allocating buff_send/recv and. Please note that for the sake of simplicity, both variables are provided sufficient storage @@ -70,23 +70,23 @@ contains halo_size = -1 + buff_size*(v_size) end if - if (bubbles_lagrange) then - beta_v_size = size(beta_vars) - beta_comm_size_1 = m + 2*mapCells + 3 - beta_comm_size_2 = merge(n + 2*mapCells + 3, 1, n>0) - beta_comm_size_3 = merge(p + 2*mapCells + 3, 1, p>0) - if (n > 0) then - if (p > 0) then - beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2*beta_comm_size_3, & - & beta_comm_size_1*beta_comm_size_3, beta_comm_size_1*beta_comm_size_2) - 1 - else - beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2, beta_comm_size_1) - 1 - end if - else - beta_halo_size = 2*(mapCells + 1)*beta_v_size - 1 - end if - halo_size = max(halo_size, beta_halo_size) - end if + if (bubbles_lagrange) then + beta_v_size = size(beta_vars) + beta_comm_size_1 = m + 2*mapCells + 3 + beta_comm_size_2 = merge(n + 2*mapCells + 3, 1, n > 0) + beta_comm_size_3 = merge(p + 2*mapCells + 3, 1, p > 0) + if (n > 0) then + if (p > 0) then + beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2*beta_comm_size_3, & + & beta_comm_size_1*beta_comm_size_3, beta_comm_size_1*beta_comm_size_2) - 1 + else + beta_halo_size = 2*(mapCells + 1)*beta_v_size*max(beta_comm_size_2, beta_comm_size_1) - 1 + end if + else + beta_halo_size = 2*(mapCells + 1)*beta_v_size - 1 + end if + halo_size = max(halo_size, beta_halo_size) + end if $:GPU_UPDATE(device='[halo_size, v_size]')