BLOCKS: Add status argument to allocate/deallocate_metablock().
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
parent
3b352c89ee
commit
34329834a6
@ -604,12 +604,20 @@ module blocks
|
||||
! subroutine arguments
|
||||
!
|
||||
type(block_meta), pointer, intent(out) :: pmeta
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: status
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
! allocate memory for the new meta block
|
||||
!
|
||||
call allocate_metablock(pmeta)
|
||||
call allocate_metablock(pmeta, status)
|
||||
|
||||
! quit if block couldn't be allocated
|
||||
!
|
||||
if (status /= 0) return
|
||||
|
||||
! check if there are any blocks in the meta block list
|
||||
!
|
||||
@ -668,6 +676,10 @@ module blocks
|
||||
!
|
||||
type(block_meta), pointer, intent(inout) :: pmeta
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: status
|
||||
|
||||
! local parameters
|
||||
!
|
||||
character(len=*), parameter :: loc = 'BLOCKS::remove_metablock()'
|
||||
@ -702,7 +714,7 @@ module blocks
|
||||
|
||||
! deallocate memory used by the meta block
|
||||
!
|
||||
call deallocate_metablock(pmeta)
|
||||
call deallocate_metablock(pmeta, status)
|
||||
|
||||
else
|
||||
|
||||
@ -872,11 +884,16 @@ module blocks
|
||||
!
|
||||
! Arguments:
|
||||
!
|
||||
! pmeta - the pointer associated with the newly allocated meta block;
|
||||
! pmeta - the pointer associated with the newly allocated meta block;
|
||||
! status - the flag indicating success or failure;
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
subroutine allocate_metablock(pmeta)
|
||||
subroutine allocate_metablock(pmeta, status)
|
||||
|
||||
! references
|
||||
!
|
||||
use iso_fortran_env, only : error_unit
|
||||
|
||||
! local variables are not implicit by default
|
||||
!
|
||||
@ -885,10 +902,15 @@ module blocks
|
||||
! subroutine arguments
|
||||
!
|
||||
type(block_meta), pointer, intent(out) :: pmeta
|
||||
integer , intent(out) :: status
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: n, i, j, k
|
||||
|
||||
! local parameters
|
||||
!
|
||||
character(len=*), parameter :: loc = 'BLOCKS::allocate_metablock()'
|
||||
!
|
||||
!-------------------------------------------------------------------------------
|
||||
!
|
||||
@ -900,83 +922,92 @@ module blocks
|
||||
|
||||
! allocate the meta block structure for one object
|
||||
!
|
||||
allocate(pmeta)
|
||||
allocate(pmeta, stat = status)
|
||||
|
||||
! check if allocation succeeded
|
||||
!
|
||||
if (status == 0) then
|
||||
|
||||
! nullify fields pointing to previous and next block on the meta block list
|
||||
!
|
||||
nullify(pmeta%prev)
|
||||
nullify(pmeta%next)
|
||||
nullify(pmeta%prev)
|
||||
nullify(pmeta%next)
|
||||
|
||||
! nullify the field pointing to the parent
|
||||
!
|
||||
nullify(pmeta%parent)
|
||||
nullify(pmeta%parent)
|
||||
|
||||
! nullify fields pointing to children
|
||||
!
|
||||
do i = 1, nchildren
|
||||
nullify(pmeta%child(i)%ptr)
|
||||
end do
|
||||
do i = 1, nchildren
|
||||
nullify(pmeta%child(i)%ptr)
|
||||
end do
|
||||
|
||||
! nullify fields pointing to face, edge, and corner neighbors
|
||||
!
|
||||
#if NDIMS == 2
|
||||
do i = 1, nsides
|
||||
do j = 1, nsides
|
||||
do n = 1, ndims
|
||||
nullify(pmeta%edges(i,j,n)%ptr)
|
||||
end do ! ndims
|
||||
nullify(pmeta%corners(i,j)%ptr)
|
||||
end do ! nsides
|
||||
end do ! nsides
|
||||
#endif /* NDIMS == 2 */
|
||||
#if NDIMS == 3
|
||||
do i = 1, nsides
|
||||
do j = 1, nsides
|
||||
do k = 1, nsides
|
||||
do i = 1, nsides
|
||||
do j = 1, nsides
|
||||
do n = 1, ndims
|
||||
nullify(pmeta%faces(i,j,k,n)%ptr)
|
||||
nullify(pmeta%edges(i,j,k,n)%ptr)
|
||||
nullify(pmeta%edges(i,j,n)%ptr)
|
||||
end do ! ndims
|
||||
nullify(pmeta%corners(i,j,k)%ptr)
|
||||
nullify(pmeta%corners(i,j)%ptr)
|
||||
end do ! nsides
|
||||
end do ! nsides
|
||||
#endif /* NDIMS == 2 */
|
||||
#if NDIMS == 3
|
||||
do i = 1, nsides
|
||||
do j = 1, nsides
|
||||
do k = 1, nsides
|
||||
do n = 1, ndims
|
||||
nullify(pmeta%faces(i,j,k,n)%ptr)
|
||||
nullify(pmeta%edges(i,j,k,n)%ptr)
|
||||
end do ! ndims
|
||||
nullify(pmeta%corners(i,j,k)%ptr)
|
||||
end do ! nsides
|
||||
end do ! nsides
|
||||
end do ! nsides
|
||||
end do ! nsides
|
||||
#endif /* NDIMS == 3 */
|
||||
|
||||
! nullify the field pointing to the associated data block
|
||||
!
|
||||
nullify(pmeta%data)
|
||||
nullify(pmeta%data)
|
||||
|
||||
! set unique ID
|
||||
!
|
||||
pmeta%id = increase_id()
|
||||
pmeta%id = increase_id()
|
||||
|
||||
! unset the process number, level, the children configuration, refine, leaf,
|
||||
! and update flags
|
||||
!
|
||||
pmeta%process = -1
|
||||
pmeta%level = -1
|
||||
pmeta%conf = -1
|
||||
pmeta%refine = 0
|
||||
pmeta%leaf = .false.
|
||||
pmeta%update = .true.
|
||||
pmeta%process = -1
|
||||
pmeta%level = -1
|
||||
pmeta%conf = -1
|
||||
pmeta%refine = 0
|
||||
pmeta%leaf = .false.
|
||||
pmeta%update = .true.
|
||||
|
||||
! initialize the position in the parent block
|
||||
!
|
||||
pmeta%pos(:) = -1
|
||||
pmeta%pos(:) = -1
|
||||
|
||||
! initialize the block coordinates in the current level
|
||||
!
|
||||
pmeta%coords(:) = 0
|
||||
pmeta%coords(:) = 0
|
||||
|
||||
! initialize coordinate bounds of the block
|
||||
!
|
||||
pmeta%xmin = 0.0d+00
|
||||
pmeta%xmax = 1.0d+00
|
||||
pmeta%ymin = 0.0d+00
|
||||
pmeta%ymax = 1.0d+00
|
||||
pmeta%zmin = 0.0d+00
|
||||
pmeta%zmax = 1.0d+00
|
||||
pmeta%xmin = 0.0d+00
|
||||
pmeta%xmax = 1.0d+00
|
||||
pmeta%ymin = 0.0d+00
|
||||
pmeta%ymax = 1.0d+00
|
||||
pmeta%zmin = 0.0d+00
|
||||
pmeta%zmax = 1.0d+00
|
||||
|
||||
else ! allocate
|
||||
write(error_unit,"('[',a,']: ',a)") trim(loc) &
|
||||
, "Cannot allocate metablock!"
|
||||
end if ! allocate
|
||||
|
||||
#ifdef PROFILE
|
||||
! stop accounting time for the meta block allocation
|
||||
@ -1003,7 +1034,7 @@ module blocks
|
||||
!
|
||||
!===============================================================================
|
||||
!
|
||||
subroutine deallocate_metablock(pmeta)
|
||||
subroutine deallocate_metablock(pmeta, status)
|
||||
|
||||
! import external procedures
|
||||
!
|
||||
@ -1016,6 +1047,7 @@ module blocks
|
||||
! subroutine arguments
|
||||
!
|
||||
type(block_meta), pointer, intent(inout) :: pmeta
|
||||
integer , intent(out) :: status
|
||||
|
||||
! local variables
|
||||
!
|
||||
@ -1088,7 +1120,7 @@ module blocks
|
||||
|
||||
! release the memory occupied by the block
|
||||
!
|
||||
deallocate(pmeta)
|
||||
deallocate(pmeta, stat = status)
|
||||
|
||||
! nullify the pointer to the deallocated meta block
|
||||
!
|
||||
@ -1100,6 +1132,7 @@ module blocks
|
||||
!
|
||||
write(error_unit,"('[',a,']: ',a)") trim(loc) &
|
||||
, "Null pointer argument to meta block!"
|
||||
status = 1
|
||||
|
||||
end if
|
||||
|
||||
@ -3955,6 +3988,10 @@ module blocks
|
||||
type(block_meta), pointer, intent(in) :: pprev
|
||||
type(block_meta), pointer, intent(out) :: pmeta
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: status
|
||||
|
||||
! local parameters
|
||||
!
|
||||
character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_after()'
|
||||
@ -3963,7 +4000,11 @@ module blocks
|
||||
!
|
||||
! allocate memory for the new meta block
|
||||
!
|
||||
call allocate_metablock(pmeta)
|
||||
call allocate_metablock(pmeta, status)
|
||||
|
||||
! quit if block couldn't be allocated
|
||||
!
|
||||
if (status /= 0) return
|
||||
|
||||
! if pprev is associated, insert the new block after it
|
||||
!
|
||||
@ -4058,6 +4099,10 @@ module blocks
|
||||
type(block_meta), pointer, intent(in) :: pnext
|
||||
type(block_meta), pointer, intent(out) :: pmeta
|
||||
|
||||
! local variables
|
||||
!
|
||||
integer :: status
|
||||
|
||||
! local parameters
|
||||
!
|
||||
character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_before()'
|
||||
@ -4066,7 +4111,11 @@ module blocks
|
||||
!
|
||||
! allocate memory for the new meta block
|
||||
!
|
||||
call allocate_metablock(pmeta)
|
||||
call allocate_metablock(pmeta, status)
|
||||
|
||||
! quit if block couldn't be allocated
|
||||
!
|
||||
if (status /= 0) return
|
||||
|
||||
! if pnext is associated, insert the new block before it
|
||||
!
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user