Skip to content

Commit 1e8655a

Browse files
sbryngelsonsbryngelson
committed
src: unify the boundary-condition dispatcher across directions
1 parent d91f691 commit 1e8655a

1 file changed

Lines changed: 76 additions & 181 deletions

File tree

‎src/common/m_boundary_common.fpp‎

Lines changed: 76 additions & 181 deletions
Original file line numberDiff line numberDiff line change
@@ -79,206 +79,101 @@ contains
7979
type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
8080
real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
8181
type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type
82-
integer :: k, l
8382
type(scalar_field), optional, intent(inout) :: q_T_sf
8483

85-
! BC type codes defined in m_constants.fpp; non-negative values are MPI boundaries
86-
87-
if (bc_x%beg >= 0) then
88-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, -1, sys_size, pb_in, mv_in, q_T_sf)
89-
else
90-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
91-
do l = 0, p
92-
do k = 0, n
93-
select case (int(bc_type(1, 1)%sf(0, k, l)))
94-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
95-
call s_ghost_cell_extrapolation(q_prim_vf, 1, -1, k, l, q_T_sf)
96-
case (BC_REFLECTIVE)
97-
call s_symmetry(q_prim_vf, 1, -1, k, l, pb_in, mv_in, q_T_sf)
98-
case (BC_PERIODIC)
99-
call s_periodic(q_prim_vf, 1, -1, k, l, pb_in, mv_in, q_T_sf)
100-
case (BC_SLIP_WALL)
101-
call s_slip_wall(q_prim_vf, 1, -1, k, l, q_T_sf)
102-
case (BC_NO_SLIP_WALL)
103-
call s_no_slip_wall(q_prim_vf, 1, -1, k, l, q_T_sf)
104-
case (BC_DIRICHLET)
105-
call s_dirichlet(q_prim_vf, 1, -1, k, l, q_T_sf)
106-
end select
107-
108-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(1, 1)%sf(0, k, &
109-
& l) <= BC_GHOST_EXTRAP)) then
110-
call s_qbmm_extrapolation(1, -1, k, l, pb_in, mv_in)
111-
end if
112-
end do
113-
end do
114-
$:END_GPU_PARALLEL_LOOP()
115-
end if
116-
117-
if (bc_x%end >= 0) then
118-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, 1, sys_size, pb_in, mv_in, q_T_sf)
119-
else
120-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
121-
do l = 0, p
122-
do k = 0, n
123-
select case (int(bc_type(1, 2)%sf(0, k, l)))
124-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP) ! Ghost-cell extrap. BC at end
125-
call s_ghost_cell_extrapolation(q_prim_vf, 1, 1, k, l, q_T_sf)
126-
case (BC_REFLECTIVE)
127-
call s_symmetry(q_prim_vf, 1, 1, k, l, pb_in, mv_in, q_T_sf)
128-
case (BC_PERIODIC)
129-
call s_periodic(q_prim_vf, 1, 1, k, l, pb_in, mv_in, q_T_sf)
130-
case (BC_SLIP_WALL)
131-
call s_slip_wall(q_prim_vf, 1, 1, k, l, q_T_sf)
132-
case (BC_NO_SLIP_WALL)
133-
call s_no_slip_wall(q_prim_vf, 1, 1, k, l, q_T_sf)
134-
case (BC_DIRICHLET)
135-
call s_dirichlet(q_prim_vf, 1, 1, k, l, q_T_sf)
136-
end select
137-
138-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(1, 2)%sf(0, k, &
139-
& l) <= BC_GHOST_EXTRAP)) then
140-
call s_qbmm_extrapolation(1, 1, k, l, pb_in, mv_in)
141-
end if
142-
end do
143-
end do
144-
$:END_GPU_PARALLEL_LOOP()
145-
end if
84+
call s_populate_bc_direction(1, -1, bc_x, bc_type(1, 1), q_prim_vf, pb_in, mv_in, q_T_sf)
85+
call s_populate_bc_direction(1, 1, bc_x, bc_type(1, 2), q_prim_vf, pb_in, mv_in, q_T_sf)
14686

14787
! Population of Buffers in y-direction
14888

14989
if (n == 0) return
15090

15191
#:if not MFC_CASE_OPTIMIZATION or num_dims > 1
152-
if (bc_y%beg >= 0) then
153-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 2, -1, sys_size, pb_in, mv_in, q_T_sf)
154-
else
155-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
156-
do l = 0, p
157-
do k = -buff_size, m + buff_size
158-
select case (int(bc_type(2, 1)%sf(k, 0, l)))
159-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
160-
call s_ghost_cell_extrapolation(q_prim_vf, 2, -1, k, l, q_T_sf)
161-
case (BC_AXIS)
162-
call s_axis(q_prim_vf, pb_in, mv_in, k, l)
163-
case (BC_REFLECTIVE)
164-
call s_symmetry(q_prim_vf, 2, -1, k, l, pb_in, mv_in, q_T_sf)
165-
case (BC_PERIODIC)
166-
call s_periodic(q_prim_vf, 2, -1, k, l, pb_in, mv_in, q_T_sf)
167-
case (BC_SLIP_WALL)
168-
call s_slip_wall(q_prim_vf, 2, -1, k, l, q_T_sf)
169-
case (BC_NO_SLIP_WALL)
170-
call s_no_slip_wall(q_prim_vf, 2, -1, k, l, q_T_sf)
171-
case (BC_DIRICHLET)
172-
call s_dirichlet(q_prim_vf, 2, -1, k, l, q_T_sf)
173-
end select
174-
175-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(2, 1)%sf(k, 0, &
176-
& l) <= BC_GHOST_EXTRAP) .and. (bc_type(2, 1)%sf(k, 0, l) /= BC_AXIS)) then
177-
call s_qbmm_extrapolation(2, -1, k, l, pb_in, mv_in)
178-
end if
179-
end do
180-
end do
181-
$:END_GPU_PARALLEL_LOOP()
182-
end if
183-
184-
if (bc_y%end >= 0) then
185-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 2, 1, sys_size, pb_in, mv_in, q_T_sf)
186-
else
187-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
188-
do l = 0, p
189-
do k = -buff_size, m + buff_size
190-
select case (int(bc_type(2, 2)%sf(k, 0, l)))
191-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
192-
call s_ghost_cell_extrapolation(q_prim_vf, 2, 1, k, l, q_T_sf)
193-
case (BC_REFLECTIVE)
194-
call s_symmetry(q_prim_vf, 2, 1, k, l, pb_in, mv_in, q_T_sf)
195-
case (BC_PERIODIC)
196-
call s_periodic(q_prim_vf, 2, 1, k, l, pb_in, mv_in, q_T_sf)
197-
case (BC_SLIP_WALL)
198-
call s_slip_wall(q_prim_vf, 2, 1, k, l, q_T_sf)
199-
case (BC_NO_SLIP_WALL)
200-
call s_no_slip_wall(q_prim_vf, 2, 1, k, l, q_T_sf)
201-
case (BC_DIRICHLET)
202-
call s_dirichlet(q_prim_vf, 2, 1, k, l, q_T_sf)
203-
end select
204-
205-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(2, 2)%sf(k, 0, &
206-
& l) <= BC_GHOST_EXTRAP)) then
207-
call s_qbmm_extrapolation(2, 1, k, l, pb_in, mv_in)
208-
end if
209-
end do
210-
end do
211-
$:END_GPU_PARALLEL_LOOP()
212-
end if
92+
call s_populate_bc_direction(2, -1, bc_y, bc_type(2, 1), q_prim_vf, pb_in, mv_in, q_T_sf)
93+
call s_populate_bc_direction(2, 1, bc_y, bc_type(2, 2), q_prim_vf, pb_in, mv_in, q_T_sf)
21394
#:endif
21495

21596
! Population of Buffers in z-direction
21697

21798
if (p == 0) return
21899

219100
#:if not MFC_CASE_OPTIMIZATION or num_dims > 2
220-
if (bc_z%beg >= 0) then
221-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 3, -1, sys_size, pb_in, mv_in, q_T_sf)
222-
else
223-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
224-
do l = -buff_size, n + buff_size
225-
do k = -buff_size, m + buff_size
226-
select case (int(bc_type(3, 1)%sf(k, l, 0)))
227-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
228-
call s_ghost_cell_extrapolation(q_prim_vf, 3, -1, k, l, q_T_sf)
229-
case (BC_REFLECTIVE)
230-
call s_symmetry(q_prim_vf, 3, -1, k, l, pb_in, mv_in, q_T_sf)
231-
case (BC_PERIODIC)
232-
call s_periodic(q_prim_vf, 3, -1, k, l, pb_in, mv_in, q_T_sf)
233-
case (BC_SLIP_WALL)
234-
call s_slip_wall(q_prim_vf, 3, -1, k, l, q_T_sf)
235-
case (BC_NO_SLIP_WALL)
236-
call s_no_slip_wall(q_prim_vf, 3, -1, k, l, q_T_sf)
237-
case (BC_DIRICHLET)
238-
call s_dirichlet(q_prim_vf, 3, -1, k, l, q_T_sf)
239-
end select
101+
call s_populate_bc_direction(3, -1, bc_z, bc_type(3, 1), q_prim_vf, pb_in, mv_in, q_T_sf)
102+
call s_populate_bc_direction(3, 1, bc_z, bc_type(3, 2), q_prim_vf, pb_in, mv_in, q_T_sf)
103+
#:endif
240104

241-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(3, 1)%sf(k, l, &
242-
& 0) <= BC_GHOST_EXTRAP)) then
243-
call s_qbmm_extrapolation(3, -1, k, l, pb_in, mv_in)
244-
end if
245-
end do
246-
end do
247-
$:END_GPU_PARALLEL_LOOP()
248-
end if
105+
end subroutine s_populate_variables_buffers
249106

250-
if (bc_z%end >= 0) then
251-
call s_mpi_sendrecv_variables_buffers(q_prim_vf, 3, 1, sys_size, pb_in, mv_in, q_T_sf)
252-
else
253-
$:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2)
254-
do l = -buff_size, n + buff_size
255-
do k = -buff_size, m + buff_size
256-
select case (int(bc_type(3, 2)%sf(k, l, 0)))
257-
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
258-
call s_ghost_cell_extrapolation(q_prim_vf, 3, 1, k, l, q_T_sf)
259-
case (BC_REFLECTIVE)
260-
call s_symmetry(q_prim_vf, 3, 1, k, l, pb_in, mv_in, q_T_sf)
261-
case (BC_PERIODIC)
262-
call s_periodic(q_prim_vf, 3, 1, k, l, pb_in, mv_in, q_T_sf)
263-
case (BC_SlIP_WALL)
264-
call s_slip_wall(q_prim_vf, 3, 1, k, l, q_T_sf)
265-
case (BC_NO_SLIP_WALL)
266-
call s_no_slip_wall(q_prim_vf, 3, 1, k, l, q_T_sf)
267-
case (BC_DIRICHLET)
268-
call s_dirichlet(q_prim_vf, 3, 1, k, l, q_T_sf)
269-
end select
107+
!> Populate the variable buffers along one direction and location, via MPI exchange for processor boundaries or by dispatching
108+
!! the per-cell BC routines over the boundary face.
109+
impure subroutine s_populate_bc_direction(bc_dir, bc_loc, bc_bounds, bc_type_edge, q_prim_vf, pb_in, mv_in, q_T_sf)
270110

271-
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_type(3, 2)%sf(k, l, &
272-
& 0) <= BC_GHOST_EXTRAP)) then
273-
call s_qbmm_extrapolation(3, 1, k, l, pb_in, mv_in)
274-
end if
275-
end do
276-
end do
277-
$:END_GPU_PARALLEL_LOOP()
278-
end if
279-
#:endif
111+
integer, intent(in) :: bc_dir, bc_loc
112+
type(int_bounds_info), intent(in) :: bc_bounds
113+
type(integer_field), intent(in) :: bc_type_edge
114+
type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
115+
real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
116+
type(scalar_field), optional, intent(inout) :: q_T_sf
117+
integer :: bc_edge, k_beg, k_end, l_beg, l_end
118+
integer :: bc_code, k, l
280119

281-
end subroutine s_populate_variables_buffers
120+
if (bc_loc == -1) then
121+
bc_edge = bc_bounds%beg
122+
else
123+
bc_edge = bc_bounds%end
124+
end if
125+
126+
! BC type codes defined in m_constants.fpp; non-negative values are MPI boundaries
127+
if (bc_edge >= 0) then
128+
call s_mpi_sendrecv_variables_buffers(q_prim_vf, bc_dir, bc_loc, sys_size, pb_in, mv_in, q_T_sf)
129+
return
130+
end if
131+
132+
if (bc_dir == 1) then
133+
k_beg = 0; k_end = n; l_beg = 0; l_end = p
134+
else if (bc_dir == 2) then
135+
k_beg = -buff_size; k_end = m + buff_size; l_beg = 0; l_end = p
136+
else
137+
k_beg = -buff_size; k_end = m + buff_size; l_beg = -buff_size; l_end = n + buff_size
138+
end if
139+
140+
$:GPU_PARALLEL_LOOP(private='[l, k, bc_code]', collapse=2)
141+
do l = l_beg, l_end
142+
do k = k_beg, k_end
143+
if (bc_dir == 1) then
144+
bc_code = int(bc_type_edge%sf(0, k, l))
145+
else if (bc_dir == 2) then
146+
bc_code = int(bc_type_edge%sf(k, 0, l))
147+
else
148+
bc_code = int(bc_type_edge%sf(k, l, 0))
149+
end if
150+
151+
select case (bc_code)
152+
case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP)
153+
call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
154+
case (BC_AXIS)
155+
if (bc_dir == 2 .and. bc_loc == -1) call s_axis(q_prim_vf, pb_in, mv_in, k, l)
156+
case (BC_REFLECTIVE)
157+
call s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
158+
case (BC_PERIODIC)
159+
call s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
160+
case (BC_SLIP_WALL)
161+
call s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
162+
case (BC_NO_SLIP_WALL)
163+
call s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
164+
case (BC_DIRICHLET)
165+
call s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
166+
end select
167+
168+
if (qbmm .and. (.not. polytropic) .and. present(pb_in) .and. present(mv_in) .and. (bc_code <= BC_GHOST_EXTRAP) &
169+
& .and. .not. (bc_dir == 2 .and. bc_loc == -1 .and. bc_code == BC_AXIS)) then
170+
call s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in)
171+
end if
172+
end do
173+
end do
174+
$:END_GPU_PARALLEL_LOOP()
175+
176+
end subroutine s_populate_bc_direction
282177

283178
!> Fill ghost cells by copying the nearest boundary cell value along the specified direction.
284179
subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)

0 commit comments

Comments
 (0)