Merge branch 'master' into binaries
This commit is contained in:
commit
a0ae13b87b
@ -1527,128 +1527,100 @@ module mesh
|
|||||||
!
|
!
|
||||||
status = 0
|
status = 0
|
||||||
|
|
||||||
! 1) check if the siblings of the block selected for derefinement, can be
|
! 1) the block can be derefined only if all its children are selected for
|
||||||
! derefined as well, if not cancel the derefinement of all siblings
|
! the derefined; otherwise reset the derefinement both for the parent
|
||||||
!
|
! and children;
|
||||||
! iterate over levels and check sibling derefinement
|
|
||||||
!
|
!
|
||||||
do l = 2, toplev
|
do l = 2, toplev
|
||||||
|
|
||||||
pmeta => list_meta
|
pmeta => list_meta
|
||||||
do while (associated(pmeta))
|
do while (associated(pmeta))
|
||||||
|
|
||||||
if (pmeta%level == l) then
|
if (pmeta%leaf .and. pmeta%level == l) then
|
||||||
if (pmeta%leaf .and. pmeta%refine == -1) then
|
if (pmeta%refine == -1) then
|
||||||
pparent => pmeta%parent
|
pparent => pmeta%parent
|
||||||
|
|
||||||
do p = 1, nchildren
|
do p = 1, nchildren
|
||||||
pchild => pparent%child(p)%ptr
|
pchild => pparent%child(p)%ptr
|
||||||
|
|
||||||
flag(p) = pchild%leaf .and. pchild%refine == -1
|
flag(p) = pchild%leaf .and. pchild%refine == -1
|
||||||
end do ! over all children
|
end do
|
||||||
|
|
||||||
! if children can be derefined, set the refine flag of the parent to -1,
|
if (all(flag)) then
|
||||||
! otherwise, cancel the derefinement of all siblings
|
|
||||||
!
|
|
||||||
if (any(flag)) then
|
|
||||||
pparent%refine = -1
|
pparent%refine = -1
|
||||||
else
|
else
|
||||||
do p = 1, nchildren
|
do p = 1, nchildren
|
||||||
pchild => pparent%child(p)%ptr
|
pchild => pparent%child(p)%ptr
|
||||||
|
|
||||||
pchild%refine = max(0, pchild%refine)
|
pchild%refine = max(0, pchild%refine)
|
||||||
end do ! children
|
end do
|
||||||
end if ! ~flag
|
end if
|
||||||
end if ! leafs selected for derefinement
|
end if
|
||||||
end if ! only block at level l
|
end if
|
||||||
|
|
||||||
pmeta => pmeta%next
|
pmeta => pmeta%next
|
||||||
end do ! iterate over meta blocks
|
end do
|
||||||
|
|
||||||
end do ! levels
|
end do
|
||||||
|
|
||||||
#ifdef MPI
|
#ifdef MPI
|
||||||
! 2) bring all siblings together to the same process
|
! 2) bring all siblings to the same process, so we can merge them into a newly
|
||||||
|
! created data block of the parent;
|
||||||
!
|
!
|
||||||
pmeta => list_meta
|
pmeta => list_meta
|
||||||
|
|
||||||
do while (associated(pmeta))
|
do while (associated(pmeta))
|
||||||
|
|
||||||
! process only parent blocks (not leafs)
|
|
||||||
!
|
|
||||||
if (.not. pmeta%leaf) then
|
if (.not. pmeta%leaf) then
|
||||||
|
|
||||||
! check if the first child is selected for derefinement
|
|
||||||
!
|
|
||||||
if (pmeta%refine == -1) then
|
if (pmeta%refine == -1) then
|
||||||
|
|
||||||
pchild => pmeta%child(1)%ptr
|
pchild => pmeta%child(1)%ptr
|
||||||
|
|
||||||
pmeta%process = pchild%process
|
pmeta%process = pchild%process
|
||||||
|
|
||||||
! iterate over the remaining children and if any of them is not on
|
|
||||||
! the same process, bring it to the parent's one
|
|
||||||
!
|
|
||||||
do p = 2, nchildren
|
do p = 2, nchildren
|
||||||
|
|
||||||
pchild => pmeta%child(p)%ptr
|
pchild => pmeta%child(p)%ptr
|
||||||
|
|
||||||
! if pchild belongs to a different process move its data block to the process
|
|
||||||
! of its parent
|
|
||||||
!
|
|
||||||
if (pchild%process /= pmeta%process) then
|
if (pchild%process /= pmeta%process) then
|
||||||
|
|
||||||
! generate the tag for communication
|
itag = pchild%id
|
||||||
!
|
|
||||||
itag = pchild%process * nprocs + pmeta%process + nprocs + p + 1
|
|
||||||
|
|
||||||
! send the child's data block from its process to the parent's process,
|
|
||||||
! and then deallocate it
|
|
||||||
!
|
|
||||||
if (pchild%process == nproc) then
|
if (pchild%process == nproc) then
|
||||||
|
call send_array(pmeta%process, itag, pchild%data%uu)
|
||||||
call send_array(pmeta%process, itag, pchild%data%uu(:,:,:,:,:))
|
|
||||||
|
|
||||||
call remove_datablock(pchild%data, status)
|
call remove_datablock(pchild%data, status)
|
||||||
if (status /= 0) then
|
if (status /= 0) then
|
||||||
call print_message(loc, "Cannot remove the data block!")
|
call print_message(loc, "Cannot remove the data block!")
|
||||||
go to 100
|
go to 100
|
||||||
end if
|
end if
|
||||||
|
end if
|
||||||
|
|
||||||
end if ! pchild%process == nproc
|
|
||||||
|
|
||||||
! on the parent's process, allocate a newdata block, and associate the data
|
|
||||||
! received from a different process
|
|
||||||
!
|
|
||||||
if (pmeta%process == nproc) then
|
if (pmeta%process == nproc) then
|
||||||
|
|
||||||
call append_datablock(pdata, status)
|
call append_datablock(pdata, status)
|
||||||
if (status == 0) then
|
if (status == 0) then
|
||||||
call link_blocks(pchild, pdata)
|
call link_blocks(pchild, pdata)
|
||||||
else
|
else
|
||||||
call print_message(loc, "Cannot append a data block!")
|
call print_message(loc, "Cannot append a new data block!")
|
||||||
go to 100
|
go to 100
|
||||||
end if
|
end if
|
||||||
|
|
||||||
call receive_array(pchild%process, itag, pdata%uu(:,:,:,:,:))
|
call receive_array(pchild%process, itag, pdata%uu)
|
||||||
|
end if
|
||||||
|
|
||||||
end if ! pmeta%process == nproc
|
|
||||||
|
|
||||||
! set the current processor of the block
|
|
||||||
!
|
|
||||||
pchild%process = pmeta%process
|
pchild%process = pmeta%process
|
||||||
|
|
||||||
end if ! pchild belongs to a different process
|
end if
|
||||||
end do ! children
|
end do
|
||||||
end if ! pmeta children are selected for derefinement
|
|
||||||
end if ! the block is parent
|
end if
|
||||||
|
|
||||||
|
end if
|
||||||
|
|
||||||
pmeta => pmeta%next
|
pmeta => pmeta%next
|
||||||
end do ! iterate over meta blocks
|
end do
|
||||||
#endif /* MPI */
|
#endif /* MPI */
|
||||||
|
|
||||||
! error entry point
|
|
||||||
!
|
|
||||||
100 continue
|
100 continue
|
||||||
|
|
||||||
!-------------------------------------------------------------------------------
|
!-------------------------------------------------------------------------------
|
||||||
|
Loading…
x
Reference in New Issue
Block a user