BOUNDARIES: Add subroutine boundaries_face_restrict().
This subroutine scans over all leafs and update their face boundaries restricting higher level neighbors to lower level ones. Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
parent
7a9922facd
commit
c91faac5f4
@ -2944,7 +2944,7 @@ module boundaries
|
||||
!
|
||||
if (pneigh%level == pmeta%level) then
|
||||
|
||||
! process only the block and its neighbor which are marked for update
|
||||
! process only blocks and neighbors which are marked for update
|
||||
!
|
||||
if (pmeta%update .and. pneigh%update) then
|
||||
|
||||
@ -3356,6 +3356,556 @@ module boundaries
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
end subroutine boundaries_face_copy
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
! subroutine BOUNDARIES_FACE_RESTRICT:
|
||||
! -----------------------------------
|
||||
!
|
||||
! Subroutine scans over all leaf blocks in order to find face neighbors which
|
||||
! are on different levels, and perform the update of face boundaries of
|
||||
! lower blocks by restricting their from higher level neighbors.
|
||||
!
|
||||
! Arguments:
|
||||
!
|
||||
! idir - the direction to be processed;
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
subroutine boundaries_face_restrict(idir)
|
||||
|
||||
! import external procedures and variables
|
||||
!
|
||||
use blocks , only : nsides
|
||||
use blocks , only : block_meta, block_data
|
||||
use blocks , only : list_meta
|
||||
use blocks , only : block_info, pointer_info
|
||||
use coordinates , only : ng
|
||||
use coordinates , only : in , jn , kn
|
||||
use coordinates , only : im , jm , km
|
||||
use coordinates , only : ib , jb , kb
|
||||
use coordinates , only : ie , je , ke
|
||||
use coordinates , only : ibl, jbl, kbl
|
||||
use coordinates , only : ieu, jeu, keu
|
||||
#ifdef MPI
|
||||
use equations , only : nv
|
||||
#endif /* MPI */
|
||||
use mpitools , only : nproc, nprocs, npmax
|
||||
#ifdef MPI
|
||||
use mpitools , only : send_real_array, receive_real_array
|
||||
#endif /* MPI */
|
||||
|
||||
! local variables are not implicit by default
|
||||
!
|
||||
implicit none
|
||||
|
||||
! subroutine arguments
|
||||
!
|
||||
integer, intent(in) :: idir
|
||||
|
||||
! local pointers
|
||||
!
|
||||
type(block_meta), pointer :: pmeta, pneigh
|
||||
#ifdef MPI
|
||||
type(block_info), pointer :: pinfo
|
||||
#endif /* MPI */
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: i , j , k
|
||||
integer :: ih, jh, kh
|
||||
integer :: il, jl, kl
|
||||
integer :: iu, ju, ku
|
||||
integer :: iret
|
||||
#ifdef MPI
|
||||
integer :: isend, irecv, nblocks, itag, l
|
||||
|
||||
! local pointer arrays
|
||||
!
|
||||
type(pointer_info), dimension(0:npmax,0:npmax) :: block_array
|
||||
|
||||
! local arrays
|
||||
!
|
||||
integer , dimension(0:npmax,0:npmax) :: block_counter
|
||||
real(kind=8), dimension(:,:,:,:,:) , allocatable :: rbuf
|
||||
#endif /* MPI */
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
#ifdef PROFILE
|
||||
! start accounting time for restrict boundary update
|
||||
!
|
||||
call start_timer(imr)
|
||||
#endif /* PROFILE */
|
||||
|
||||
! calculate half sizes
|
||||
!
|
||||
ih = in / 2
|
||||
jh = jn / 2
|
||||
kh = kn / 2
|
||||
|
||||
#ifdef MPI
|
||||
!! 1. PREPARE THE BLOCK EXCHANGE ARRAYS FOR MPI
|
||||
!!
|
||||
! reset the exchange block counters
|
||||
!
|
||||
block_counter(:,:) = 0
|
||||
|
||||
! nullify the info pointers
|
||||
!
|
||||
do irecv = 0, npmax
|
||||
do isend = 0, npmax
|
||||
nullify(block_array(isend,irecv)%ptr)
|
||||
end do
|
||||
end do
|
||||
#endif /* MPI */
|
||||
|
||||
!! 2. UPDATE VARIABLE FACE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT
|
||||
!! PROCESS AND PREPARE THE EXCHANGE BLOCK LIST OF BLOCKS WHICH BELONG TO
|
||||
!! DIFFERENT PROCESSES
|
||||
!!
|
||||
! associate pmeta with the first block on the meta block list
|
||||
!
|
||||
pmeta => list_meta
|
||||
|
||||
! scan all meta blocks
|
||||
!
|
||||
do while(associated(pmeta))
|
||||
|
||||
! check if the block is leaf
|
||||
!
|
||||
if (pmeta%leaf) then
|
||||
|
||||
! scan over all block corners
|
||||
!
|
||||
do k = 1, nsides
|
||||
do j = 1, nsides
|
||||
do i = 1, nsides
|
||||
|
||||
! associate pneigh with the current neighbor
|
||||
!
|
||||
pneigh => pmeta%faces(i,j,k,idir)%ptr
|
||||
|
||||
! check if the neighbor is associated
|
||||
!
|
||||
if (associated(pneigh)) then
|
||||
|
||||
! check if the neighbor is at higher level
|
||||
!
|
||||
if (pneigh%level > pmeta%level) then
|
||||
|
||||
! process only blocks and neighbors which are marked for update
|
||||
!
|
||||
if (pmeta%update .and. pneigh%update) then
|
||||
|
||||
#ifdef MPI
|
||||
! check if the block and its neighbor belong to the same process
|
||||
!
|
||||
if (pmeta%process == pneigh%process) then
|
||||
|
||||
! check if the neighbor belongs to the current process
|
||||
!
|
||||
if (pmeta%process == nproc) then
|
||||
#endif /* MPI */
|
||||
|
||||
! prepare the region indices for face boundary update
|
||||
!
|
||||
select case(idir)
|
||||
case(1)
|
||||
if (i == 1) then
|
||||
il = 1
|
||||
iu = ibl
|
||||
else
|
||||
il = ieu
|
||||
iu = im
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = jb
|
||||
ju = jb + jh - 1
|
||||
else
|
||||
jl = je - jh + 1
|
||||
ju = je
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = kb
|
||||
ku = kb + kh - 1
|
||||
else
|
||||
kl = ke - kh + 1
|
||||
ku = ke
|
||||
end if
|
||||
case(2)
|
||||
if (i == 1) then
|
||||
il = ib
|
||||
iu = ib + ih - 1
|
||||
else
|
||||
il = ie - ih + 1
|
||||
iu = ie
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = 1
|
||||
ju = jbl
|
||||
else
|
||||
jl = jeu
|
||||
ju = jm
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = kb
|
||||
ku = kb + kh - 1
|
||||
else
|
||||
kl = ke - kh + 1
|
||||
ku = ke
|
||||
end if
|
||||
case(3)
|
||||
if (i == 1) then
|
||||
il = ib
|
||||
iu = ib + ih - 1
|
||||
else
|
||||
il = ie - ih + 1
|
||||
iu = ie
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = jb
|
||||
ju = jb + jh - 1
|
||||
else
|
||||
jl = je - jh + 1
|
||||
ju = je
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = 1
|
||||
ku = kbl
|
||||
else
|
||||
kl = keu
|
||||
ku = km
|
||||
end if
|
||||
end select
|
||||
|
||||
! extract the corresponding face region from the neighbor and insert it in
|
||||
! the current data block
|
||||
!
|
||||
call block_face_restrict(idir, i, j, k &
|
||||
, pneigh%data%q(1:nv, 1:im, 1:jm, 1:km) &
|
||||
, pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku))
|
||||
|
||||
#ifdef MPI
|
||||
end if ! pneigh on the current process
|
||||
|
||||
else ! block and neighbor belong to different processes
|
||||
|
||||
! increase the counter for number of blocks to exchange
|
||||
!
|
||||
block_counter(pneigh%process,pmeta%process) = &
|
||||
block_counter(pneigh%process,pmeta%process) + 1
|
||||
|
||||
! allocate a new info object
|
||||
!
|
||||
allocate(pinfo)
|
||||
|
||||
! fill out only fields which are used
|
||||
!
|
||||
pinfo%block => pmeta
|
||||
pinfo%neigh => pneigh
|
||||
pinfo%direction = idir
|
||||
pinfo%corner(1) = i
|
||||
pinfo%corner(2) = j
|
||||
pinfo%corner(3) = k
|
||||
|
||||
! nullify pointer fields of the object
|
||||
!
|
||||
nullify(pinfo%prev)
|
||||
nullify(pinfo%next)
|
||||
|
||||
! if the list is not empty append the newly created block to it
|
||||
!
|
||||
if (associated(block_array(pneigh%process &
|
||||
,pmeta%process)%ptr)) &
|
||||
pinfo%prev => block_array(pneigh%process &
|
||||
,pmeta%process)%ptr
|
||||
|
||||
! point the list to the newly created block
|
||||
!
|
||||
block_array(pneigh%process,pmeta%process)%ptr => pinfo
|
||||
|
||||
end if ! block and neighbor belong to different processes
|
||||
#endif /* MPI */
|
||||
|
||||
end if ! pmeta and pneigh marked for update
|
||||
|
||||
end if ! neighbor at the same level
|
||||
|
||||
end if ! neighbor associated
|
||||
|
||||
end do ! i = 1, nsides
|
||||
end do ! j = 1, nsides
|
||||
end do ! k = 1, nsides
|
||||
|
||||
end if ! leaf
|
||||
|
||||
! associate pmeta with the next meta block
|
||||
!
|
||||
pmeta => pmeta%next
|
||||
|
||||
end do ! meta blocks
|
||||
|
||||
#ifdef MPI
|
||||
!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES
|
||||
!!
|
||||
! iterate over sending and receiving processors
|
||||
!
|
||||
do irecv = 0, npmax
|
||||
do isend = 0, npmax
|
||||
|
||||
! process only pairs which have something to exchange
|
||||
!
|
||||
if (block_counter(isend,irecv) > 0) then
|
||||
|
||||
! obtain the number of blocks to exchange
|
||||
!
|
||||
nblocks = block_counter(isend,irecv)
|
||||
|
||||
! prepare the tag for communication
|
||||
!
|
||||
itag = 100 * (irecv * nprocs + isend + 1) + 12
|
||||
|
||||
! allocate data buffer for variables to exchange
|
||||
!
|
||||
select case(idir)
|
||||
case(1)
|
||||
allocate(rbuf(nblocks,nv,ng,jh,kh))
|
||||
case(2)
|
||||
allocate(rbuf(nblocks,nv,ih,ng,kh))
|
||||
case(3)
|
||||
allocate(rbuf(nblocks,nv,ih,jh,ng))
|
||||
end select
|
||||
|
||||
! if isend == nproc we are sending data
|
||||
!
|
||||
if (isend == nproc) then
|
||||
|
||||
! reset the block counter
|
||||
!
|
||||
l = 0
|
||||
|
||||
! associate pinfo with the first block in the exchange list
|
||||
!
|
||||
pinfo => block_array(isend,irecv)%ptr
|
||||
|
||||
! scan over all blocks on the block exchange list
|
||||
!
|
||||
do while(associated(pinfo))
|
||||
|
||||
! increase the block counter
|
||||
!
|
||||
l = l + 1
|
||||
|
||||
! associate pneigh with pinfo%neigh
|
||||
!
|
||||
pneigh => pinfo%neigh
|
||||
|
||||
! get the corner coordinates
|
||||
!
|
||||
i = pinfo%corner(1)
|
||||
j = pinfo%corner(2)
|
||||
k = pinfo%corner(3)
|
||||
|
||||
! extract the corresponding face region from the neighbor and insert it
|
||||
! to the buffer
|
||||
!
|
||||
select case(idir)
|
||||
case(1)
|
||||
call block_face_restrict(idir, i, j, k &
|
||||
, pneigh%data%q(1:nv,1:im,1:jm,1:km) &
|
||||
, rbuf(l,1:nv,1:ng,1:jh,1:kh))
|
||||
case(2)
|
||||
call block_face_restrict(idir, i, j, k &
|
||||
, pneigh%data%q(1:nv,1:im,1:jm,1:km) &
|
||||
, rbuf(l,1:nv,1:ih,1:ng,1:kh))
|
||||
case(3)
|
||||
call block_face_restrict(idir, i, j, k &
|
||||
, pneigh%data%q(1:nv,1:im,1:jm,1:km) &
|
||||
, rbuf(l,1:nv,1:ih,1:jh,1:ng))
|
||||
end select
|
||||
|
||||
! associate pinfo with the next block
|
||||
!
|
||||
pinfo => pinfo%prev
|
||||
|
||||
end do ! %ptr block list
|
||||
|
||||
! send the data buffer to another process
|
||||
!
|
||||
call send_real_array(size(rbuf), irecv, itag, rbuf(:,:,:,:,:), iret)
|
||||
|
||||
end if ! isend = nproc
|
||||
|
||||
! if irecv == nproc we are receiving data
|
||||
!
|
||||
if (irecv == nproc) then
|
||||
|
||||
! receive the data buffer
|
||||
!
|
||||
call receive_real_array(size(rbuf(:,:,:,:,:)), isend, itag &
|
||||
, rbuf(:,:,:,:,:), iret)
|
||||
|
||||
! reset the block counter
|
||||
!
|
||||
l = 0
|
||||
|
||||
! associate pinfo with the first block in the exchange list
|
||||
!
|
||||
pinfo => block_array(isend,irecv)%ptr
|
||||
|
||||
! iterate over all received blocks and update boundaries of the corresponding
|
||||
! data blocks
|
||||
!
|
||||
do while(associated(pinfo))
|
||||
|
||||
! increase the block counter
|
||||
!
|
||||
l = l + 1
|
||||
|
||||
! associate pmeta with pinfo%block
|
||||
!
|
||||
pmeta => pinfo%block
|
||||
|
||||
! get the corner coordinates
|
||||
!
|
||||
i = pinfo%corner(1)
|
||||
j = pinfo%corner(2)
|
||||
k = pinfo%corner(3)
|
||||
|
||||
! update the corresponding face region of the current block
|
||||
!
|
||||
select case(idir)
|
||||
case(1)
|
||||
if (i == 1) then
|
||||
il = 1
|
||||
iu = ibl
|
||||
else
|
||||
il = ieu
|
||||
iu = im
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = jb
|
||||
ju = jb + jh - 1
|
||||
else
|
||||
jl = je - jh + 1
|
||||
ju = je
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = kb
|
||||
ku = kb + kh - 1
|
||||
else
|
||||
kl = ke - kh + 1
|
||||
ku = ke
|
||||
end if
|
||||
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = &
|
||||
rbuf(l,1:nv,1:ng,1:jh,1:kh)
|
||||
case(2)
|
||||
if (i == 1) then
|
||||
il = ib
|
||||
iu = ib + ih - 1
|
||||
else
|
||||
il = ie - ih + 1
|
||||
iu = ie
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = 1
|
||||
ju = jbl
|
||||
else
|
||||
jl = jeu
|
||||
ju = jm
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = kb
|
||||
ku = kb + kh - 1
|
||||
else
|
||||
kl = ke - kh + 1
|
||||
ku = ke
|
||||
end if
|
||||
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = &
|
||||
rbuf(l,1:nv,1:ih,1:ng,1:kh)
|
||||
case(3)
|
||||
if (i == 1) then
|
||||
il = ib
|
||||
iu = ib + ih - 1
|
||||
else
|
||||
il = ie - ih + 1
|
||||
iu = ie
|
||||
end if
|
||||
if (j == 1) then
|
||||
jl = jb
|
||||
ju = jb + jh - 1
|
||||
else
|
||||
jl = je - jh + 1
|
||||
ju = je
|
||||
end if
|
||||
if (k == 1) then
|
||||
kl = 1
|
||||
ku = kbl
|
||||
else
|
||||
kl = keu
|
||||
ku = km
|
||||
end if
|
||||
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = &
|
||||
rbuf(l,1:nv,1:ih,1:jh,1:ng)
|
||||
end select
|
||||
|
||||
! associate pinfo with the next block
|
||||
!
|
||||
pinfo => pinfo%prev
|
||||
|
||||
end do ! %ptr block list
|
||||
|
||||
end if ! irecv = nproc
|
||||
|
||||
! deallocate data buffer
|
||||
!
|
||||
if (allocated(rbuf)) deallocate(rbuf)
|
||||
|
||||
! associate pinfo with the first block in the exchange list
|
||||
!
|
||||
pinfo => block_array(isend,irecv)%ptr
|
||||
|
||||
! scan over all blocks on the exchange block list
|
||||
!
|
||||
do while(associated(pinfo))
|
||||
|
||||
! associate the exchange list pointer with the previous block
|
||||
!
|
||||
block_array(isend,irecv)%ptr => pinfo%prev
|
||||
|
||||
! nullify the pointer fields
|
||||
!
|
||||
nullify(pinfo%prev)
|
||||
nullify(pinfo%next)
|
||||
nullify(pinfo%block)
|
||||
nullify(pinfo%neigh)
|
||||
|
||||
! deallocate the object
|
||||
!
|
||||
deallocate(pinfo)
|
||||
|
||||
! associate pinfo with the next block
|
||||
!
|
||||
pinfo => block_array(isend,irecv)%ptr
|
||||
|
||||
end do ! %ptr block list
|
||||
|
||||
end if ! if block_count > 0
|
||||
|
||||
end do ! isend
|
||||
end do ! irecv
|
||||
#endif /* MPI */
|
||||
|
||||
#ifdef PROFILE
|
||||
! stop accounting time for restrict boundary update
|
||||
!
|
||||
call stop_timer(imr)
|
||||
#endif /* PROFILE */
|
||||
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
end subroutine boundaries_face_restrict
|
||||
#endif /* NDIMS == 3 */
|
||||
!
|
||||
!===============================================================================
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user