diff --git a/sources/boundaries.F90 b/sources/boundaries.F90 index f227b4d..aeb25ed 100644 --- a/sources/boundaries.F90 +++ b/sources/boundaries.F90 @@ -924,7 +924,7 @@ module boundaries ! restricts corner boundaries from blocks at higher levels ! - call boundaries_corner_restrict() + call boundaries_corner_restrict(status) ! update specific boundaries ! @@ -4016,63 +4016,77 @@ module boundaries ! subroutine BOUNDARIES_CORNER_RESTRICT: ! ------------------------------------- ! -! Subroutine updates the corner boundaries from blocks on higher level. +! Subroutine updates the blocks' corner ghost zones from blocks +! at higher levels. ! +! Arguments: +! +! status - the call status; ! !=============================================================================== ! - subroutine boundaries_corner_restrict() + subroutine boundaries_corner_restrict(status) -! import external procedures and variables -! use blocks , only : nsides use blocks , only : block_meta, block_data, block_leaf use blocks , only : list_leaf use blocks , only : block_info, pointer_info -#ifdef MPI - use coordinates, only : ng => nghosts -#endif /* MPI */ - use coordinates, only : corners_gr + use coordinates, only : nn => bcells, ng => nghosts use equations , only : nv #ifdef MPI + use helpers , only : print_message use mpitools , only : nproc, npairs, pairs use mpitools , only : exchange_arrays #endif /* MPI */ -! local variables are not implicit by default -! implicit none -! local pointers -! + integer, intent(out) :: status + type(block_meta), pointer :: pmeta, pneigh + type(block_data), pointer :: pdata type(block_leaf), pointer :: pleaf #ifdef MPI type(block_info), pointer :: pinfo #endif /* MPI */ -! local variables -! integer :: i, il, iu integer :: j, jl, ju - integer :: k -#if NDIMS == 3 - integer :: kl, ku -#endif /* NDIMS == 3 */ + integer :: k, kl, ku #ifdef MPI integer :: sproc, rproc integer :: scount, rcount integer :: l, p -! local arrays -! real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf #endif /* MPI */ -! + + logical , save :: first = .true. + integer, dimension(2,2), save :: nlims + +#ifdef MPI + character(len=*), parameter :: loc = & + 'BOUNDARIES::boundaries_corner_restrict()' +#endif /* MPI */ + !------------------------------------------------------------------------------- ! + if (first) then + + nlims(1,1) = 1 + nlims(1,2) = ng + nlims(2,1) = nn - ng + 1 + nlims(2,2) = nn + + first = .false. + end if + + status = 0 + #if NDIMS == 2 - k = 1 + k = 1 + kl = 1 + ku = 1 #endif /* NDIMS == 2 */ #ifdef MPI @@ -4081,35 +4095,28 @@ module boundaries scount = 0 rcount = 0 -! prepare the block exchange structures -! call prepare_exchange_array() #endif /* MPI */ -! update boundaries between blocks on the same process -! -! associate pleaf with the first block on the leaf list -! pleaf => list_leaf -! scan all leaf meta blocks in the list -! do while(associated(pleaf)) -! get the associated meta block -! pmeta => pleaf%meta + pdata => pmeta%data -! scan over all block corners -! #if NDIMS == 3 do k = 1, nsides + kl = nlims(k,1) + ku = nlims(k,2) #endif /* NDIMS == 3 */ do j = 1, nsides + jl = nlims(j,1) + ju = nlims(j,2) do i = 1, nsides + il = nlims(i,1) + iu = nlims(i,2) -! assign pneigh to the current neighbor -! #if NDIMS == 2 pneigh => pmeta%corners(i,j)%ptr #endif /* NDIMS == 2 */ @@ -4117,101 +4124,50 @@ module boundaries pneigh => pmeta%corners(i,j,k)%ptr #endif /* NDIMS == 3 */ -! check if the neighbor is associated -! if (associated(pneigh)) then -! check if the neighbor is at higher level -! if (pneigh%level > pmeta%level) then -! skip if the block and its neighbor are not marked for update -! if (pmeta%update .or. 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 (pneigh%process == nproc) then #endif /* MPI */ -! prepare the region indices for corner boundary update -! -#if NDIMS == 2 - il = corners_gr(i,j )%l(1) - jl = corners_gr(i,j )%l(2) - iu = corners_gr(i,j )%u(1) - ju = corners_gr(i,j )%u(2) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - il = corners_gr(i,j,k)%l(1) - jl = corners_gr(i,j,k)%l(2) - kl = corners_gr(i,j,k)%l(3) - iu = corners_gr(i,j,k)%u(1) - ju = corners_gr(i,j,k)%u(2) - ku = corners_gr(i,j,k)%u(3) -#endif /* NDIMS == 3 */ - -! extract and restrict the corresponding corner region from the neighbor and -! insert it in the current data block -! -#if NDIMS == 2 - call block_corner_restrict((/ i, j, k /) & - , pneigh%data%q(1:nv, : , : , : ) & - , pmeta%data%q(1:nv,il:iu,jl:ju, : )) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - call block_corner_restrict((/ i, j, k /) & - , pneigh%data%q(1:nv, : , : , : ) & - , pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku)) -#endif /* NDIMS == 3 */ + call block_corner_restrict([ i, j, k ], pneigh%data%q, & + pdata%q(1:nv,il:iu,jl:ju,kl:ku)) #ifdef MPI - end if ! block on the current processor + end if - else ! block and neighbor on different processors + else -! append the block to the exchange list -! - call append_exchange_block(pmeta, pneigh, -1, (/ i, j, k /)) + call append_exchange_block(pmeta, pneigh, -1, [ i, j, k ]) - end if ! block and neighbor on different processors + end if #endif /* MPI */ - end if ! pmeta and pneigh marked for update + end if - end if ! neighbor at higher level + end if - end if ! neighbor associated + end if - end do ! i = 1, nsides - end do ! j = 1, nsides + end do + end do #if NDIMS == 3 - end do ! k = 1, nsides + end do #endif /* NDIMS == 3 */ -! associate pleaf with the next leaf on the list -! pleaf => pleaf%next - - end do ! over leaf blocks + end do #ifdef MPI -!! 3. UPDATE VARIABLE BOUNDARIES BETWEEN BLOCKS BELONGING TO DIFFERENT PROCESSES -!! -! iterate over all process pairs -! do p = 1, npairs -! process only pairs related to this process -! if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then -! get sending and receiving process identifiers (depending on pair member) -! if (pairs(p,1) == nproc) then sproc = pairs(p,1) rproc = pairs(p,2) @@ -4221,157 +4177,89 @@ module boundaries rproc = pairs(p,1) end if -! get the number of blocks to exchange -! scount = bcount(sproc,rproc) rcount = bcount(rproc,sproc) -! process only pairs which have anything to exchange -! - if ((scount + rcount) > 0) then + if (scount > 0 .or. rcount > 0) then -! allocate buffers for variable exchange -! -#if NDIMS == 2 - allocate(sbuf(scount,nv,ng,ng, 1)) - allocate(rbuf(rcount,nv,ng,ng, 1)) -#endif /* NDIMS == 2 */ #if NDIMS == 3 - allocate(sbuf(scount,nv,ng,ng,ng)) - allocate(rbuf(rcount,nv,ng,ng,ng)) + allocate(sbuf(nv,ng,ng,ng,scount), & + rbuf(nv,ng,ng,ng,rcount), stat=status) +#else /* NDIMS == 3 */ + allocate(sbuf(nv,ng,ng, 1,scount), & + rbuf(nv,ng,ng, 1,rcount), stat=status) +#endif /* NDIMS == 3 */ + if (status /= 0) & + call print_message(loc, "Could not allocate the exchange buffers!") + + if (scount > 0) then + + l = 0 + + pinfo => barray(sproc,rproc)%ptr + + do while(associated(pinfo)) + + l = l + 1 + + pneigh => pinfo%neigh + + i = pinfo%corner(1) + j = pinfo%corner(2) +#if NDIMS == 3 + k = pinfo%corner(3) #endif /* NDIMS == 3 */ -!! PREPARE BLOCKS FOR SENDING -!! -! reset the block counter -! - l = 0 + call block_corner_restrict([ i, j, k ], pneigh%data%q, & + sbuf(:,:,:,:,l)) -! associate the pointer with the first block in the exchange list -! - pinfo => barray(sproc,rproc)%ptr + pinfo => pinfo%prev -! scan over all blocks on the block exchange list -! - do while(associated(pinfo)) + end do -! increase the block counter -! - l = l + 1 + end if -! assign pneigh to the associated neighbor block -! - pneigh => pinfo%neigh - -! get the corner coordinates -! - i = pinfo%corner(1) - j = pinfo%corner(2) -#if NDIMS == 3 - k = pinfo%corner(3) -#endif /* NDIMS == 3 */ - -! restrict and extract the corresponding corner region from the neighbor and -! insert it to the buffer -! -#if NDIMS == 2 - call block_corner_restrict((/ i, j, k /) & - , pneigh%data%q(1:nv, : , : , : ) & - , sbuf(l,1:nv,1:ng,1:ng,1: )) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - call block_corner_restrict((/ i, j, k /) & - , pneigh%data%q(1:nv, : , : , : ) & - , sbuf(l,1:nv,1:ng,1:ng,1:ng)) -#endif /* NDIMS == 3 */ - -! associate the pointer with the next block -! - pinfo => pinfo%prev - - end do ! %ptr block list - -!! SEND PREPARED BLOCKS AND RECEIVE NEW ONES -!! -! exchange data -! call exchange_arrays(rproc, p, sbuf, rbuf) -!! PROCESS RECEIVED BLOCKS -!! -! reset the block counter -! - l = 0 + if (rcount > 0) then -! associate the pointer with the first block in the exchange list -! - pinfo => barray(rproc,sproc)%ptr + l = 0 -! iterate over all received blocks and update boundaries of the corresponding -! data blocks -! - do while(associated(pinfo)) + pinfo => barray(rproc,sproc)%ptr -! increase the block counter -! - l = l + 1 + do while(associated(pinfo)) -! assign a pointer to the associated data block -! - pmeta => pinfo%meta + l = l + 1 -! get the corner coordinates -! - i = pinfo%corner(1) - j = pinfo%corner(2) + pmeta => pinfo%meta + + il = nlims(pinfo%corner(1),1) + iu = nlims(pinfo%corner(1),2) + jl = nlims(pinfo%corner(2),1) + ju = nlims(pinfo%corner(2),2) #if NDIMS == 3 - k = pinfo%corner(3) + kl = nlims(pinfo%corner(3),1) + ku = nlims(pinfo%corner(3),2) #endif /* NDIMS == 3 */ -! prepare the region indices for corner boundary update -! -#if NDIMS == 2 - il = corners_gr(i,j )%l(1) - jl = corners_gr(i,j )%l(2) - iu = corners_gr(i,j )%u(1) - ju = corners_gr(i,j )%u(2) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - il = corners_gr(i,j,k)%l(1) - jl = corners_gr(i,j,k)%l(2) - kl = corners_gr(i,j,k)%l(3) - iu = corners_gr(i,j,k)%u(1) - ju = corners_gr(i,j,k)%u(2) - ku = corners_gr(i,j,k)%u(3) -#endif /* NDIMS == 3 */ + pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(:,:,:,:,l) -! update the corresponding corner region of the current block -! -#if NDIMS == 2 - pmeta%data%q(1:nv,il:iu,jl:ju, : ) = rbuf(l,1:nv,1:ng,1:ng, : ) -#endif /* NDIMS == 2 */ -#if NDIMS == 3 - pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:ng) -#endif /* NDIMS == 3 */ + pinfo => pinfo%prev + end do -! associate the pointer with the next block -! - pinfo => pinfo%prev + end if - end do ! %ptr block list + deallocate(sbuf, rbuf, stat=status) + if (status /= 0) & + call print_message(loc, & + "Could not deallocate the exchange buffers!") -! deallocate data buffer -! - deallocate(sbuf, rbuf) + end if - end if ! (scount + rcount) > 0 - - end if ! pairs(p,1) == nproc || pairs(p,2) == nproc + end if end do ! p = 1, npairs -! release the memory used by the array of exchange block lists -! call release_exchange_array() #endif /* MPI */ @@ -4384,7 +4272,8 @@ module boundaries ! subroutine BOUNDARIES_CORNER_PROLONG: ! ------------------------------------ ! -! Subroutine updates the corner boundaries from blocks on lower level. +! Subroutine updates the blocks' corner ghost zones from blocks +! at lower levels. ! ! Arguments: ! @@ -4446,6 +4335,8 @@ module boundaries first = .false. end if + status = 0 + #if NDIMS == 2 k = 1 kl = 1