diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index f407bdbcf1..ca0cd74e06 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -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..72babc4a49 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,71 @@ 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, & - & 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 + 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 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 +1459,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 +1521,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 +1529,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 +1539,96 @@ 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, & - & l)) - y_kahan - q_beta(beta_vars(i))%sf(m - (j - 1), k, l) = t_kahan + 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(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), & - & l)) - y_kahan - q_beta(beta_vars(i))%sf(k, n - (j - 1), l) = t_kahan + 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(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, & - & p - (j - 1))) - y_kahan - q_beta(beta_vars(i))%sf(k, l, p - (j - 1)) = t_kahan + 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(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..145a72c3ea 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. @@ -68,6 +70,24 @@ 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 + $:GPU_UPDATE(device='[halo_size, v_size]') #ifndef __NVCOMPILER_GPU_UNIFIED_MEM @@ -1075,11 +1095,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 +1175,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 +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(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(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 @@ -1184,8 +1205,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 +1267,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 +1293,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 +1319,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 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