gkowal/amun-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

BLOCKS: Add status argument to allocate/deallocate_metablock().

Browse Source 
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
Grzegorz Kowal 2019-02-11 11:54:43 -02:00
parent 3b352c89ee
commit 34329834a6
1 changed files with 97 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
sources/blocks.F90
View File

@ -604,12 +604,20 @@ module blocks
! subroutine arguments ! subroutine arguments
! !
type(block_meta), pointer, intent(out) :: pmeta type(block_meta), pointer, intent(out) :: pmeta
! local variables
!
integer :: status
! !
!------------------------------------------------------------------------------- !-------------------------------------------------------------------------------
! !
! allocate memory for the new meta block ! 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 ! check if there are any blocks in the meta block list
! !
@ -668,6 +676,10 @@ module blocks
! !
type(block_meta), pointer, intent(inout) :: pmeta type(block_meta), pointer, intent(inout) :: pmeta
! local variables
!
integer :: status
! local parameters ! local parameters
! !
character(len=*), parameter :: loc = 'BLOCKS::remove_metablock()' character(len=*), parameter :: loc = 'BLOCKS::remove_metablock()'
@ -702,7 +714,7 @@ module blocks
! deallocate memory used by the meta block ! deallocate memory used by the meta block
! !
call deallocate_metablock(pmeta) call deallocate_metablock(pmeta, status)
else else
@ -872,11 +884,16 @@ module blocks
! !
! Arguments: ! 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 ! local variables are not implicit by default
! !
@ -885,10 +902,15 @@ module blocks
! subroutine arguments ! subroutine arguments
! !
type(block_meta), pointer, intent(out) :: pmeta type(block_meta), pointer, intent(out) :: pmeta
integer , intent(out) :: status
! local variables ! local variables
! !
integer :: n, i, j, k 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 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 fields pointing to previous and next block on the meta block list
! !
nullify(pmeta%prev) nullify(pmeta%prev)
nullify(pmeta%next) nullify(pmeta%next)
! nullify the field pointing to the parent ! nullify the field pointing to the parent
! !
nullify(pmeta%parent) nullify(pmeta%parent)
! nullify fields pointing to children ! nullify fields pointing to children
! !
do i = 1, nchildren do i = 1, nchildren
nullify(pmeta%child(i)%ptr) nullify(pmeta%child(i)%ptr)
end do end do
! nullify fields pointing to face, edge, and corner neighbors ! nullify fields pointing to face, edge, and corner neighbors
! !
#if NDIMS == 2 #if NDIMS == 2
do i = 1, nsides do i = 1, nsides
do j = 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 n = 1, ndims do n = 1, ndims
nullify(pmeta%faces(i,j,k,n)%ptr) nullify(pmeta%edges(i,j,n)%ptr)
nullify(pmeta%edges(i,j,k,n)%ptr)
end do ! ndims 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 end do ! nsides
end do ! nsides
#endif /* NDIMS == 3 */ #endif /* NDIMS == 3 */
! nullify the field pointing to the associated data block ! nullify the field pointing to the associated data block
! !
nullify(pmeta%data) nullify(pmeta%data)
! set unique ID ! set unique ID
! !
pmeta%id = increase_id() pmeta%id = increase_id()
! unset the process number, level, the children configuration, refine, leaf, ! unset the process number, level, the children configuration, refine, leaf,
! and update flags ! and update flags
! !
pmeta%process = -1 pmeta%process = -1
pmeta%level = -1 pmeta%level = -1
pmeta%conf = -1 pmeta%conf = -1
pmeta%refine = 0 pmeta%refine = 0
pmeta%leaf = .false. pmeta%leaf = .false.
pmeta%update = .true. pmeta%update = .true.
! initialize the position in the parent block ! initialize the position in the parent block
! !
pmeta%pos(:) = -1 pmeta%pos(:) = -1
! initialize the block coordinates in the current level ! initialize the block coordinates in the current level
! !
pmeta%coords(:) = 0 pmeta%coords(:) = 0
! initialize coordinate bounds of the block ! initialize coordinate bounds of the block
! !
pmeta%xmin = 0.0d+00 pmeta%xmin = 0.0d+00
pmeta%xmax = 1.0d+00 pmeta%xmax = 1.0d+00
pmeta%ymin = 0.0d+00 pmeta%ymin = 0.0d+00
pmeta%ymax = 1.0d+00 pmeta%ymax = 1.0d+00
pmeta%zmin = 0.0d+00 pmeta%zmin = 0.0d+00
pmeta%zmax = 1.0d+00 pmeta%zmax = 1.0d+00
else ! allocate
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot allocate metablock!"
end if ! allocate
#ifdef PROFILE #ifdef PROFILE
! stop accounting time for the meta block allocation ! 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 ! import external procedures
! !
@ -1016,6 +1047,7 @@ module blocks
! subroutine arguments ! subroutine arguments
! !
type(block_meta), pointer, intent(inout) :: pmeta type(block_meta), pointer, intent(inout) :: pmeta
integer , intent(out) :: status
! local variables ! local variables
! !
@ -1088,7 +1120,7 @@ module blocks
! release the memory occupied by the block ! release the memory occupied by the block
! !
deallocate(pmeta) deallocate(pmeta, stat = status)
! nullify the pointer to the deallocated meta block ! nullify the pointer to the deallocated meta block
! !
@ -1100,6 +1132,7 @@ module blocks
! !
write(error_unit,"('[',a,']: ',a)") trim(loc) & write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Null pointer argument to meta block!" , "Null pointer argument to meta block!"
status = 1
end if end if
@ -3955,6 +3988,10 @@ module blocks
type(block_meta), pointer, intent(in) :: pprev type(block_meta), pointer, intent(in) :: pprev
type(block_meta), pointer, intent(out) :: pmeta type(block_meta), pointer, intent(out) :: pmeta
! local variables
!
integer :: status
! local parameters ! local parameters
! !
character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_after()' character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_after()'
@ -3963,7 +4000,11 @@ module blocks
! !
! allocate memory for the new meta block ! 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 ! 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(in) :: pnext
type(block_meta), pointer, intent(out) :: pmeta type(block_meta), pointer, intent(out) :: pmeta
! local variables
!
integer :: status
! local parameters ! local parameters
! !
character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_before()' character(len=*), parameter :: loc = 'BLOCKS::insert_metablock_before()'
@ -4066,7 +4111,11 @@ module blocks
! !
! allocate memory for the new meta block ! 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 ! if pnext is associated, insert the new block before it
! !