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

BLOCKS: Add status argument to insert_metablock_after/before().

Browse Source 
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
Grzegorz Kowal 2019-02-11 12:26:57 -02:00
parent 5caf3f37cf
commit 4e688b8fcd
1 changed files with 29 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
sources/blocks.F90
View File

@ -1466,6 +1466,7 @@ module blocks
! local variables ! local variables
! !
logical, save :: first = .true. logical, save :: first = .true.
integer :: status
integer :: p , q integer :: p , q
integer :: i , j , k integer :: i , j , k
integer :: ip, jp, kp, np integer :: ip, jp, kp, np
@ -1587,16 +1588,20 @@ module blocks
! insert a new meta block after pmeta and associate it with pchild ! insert a new meta block after pmeta and associate it with pchild
! !
call insert_metablock_after(pmeta, pchild) call insert_metablock_after(pmeta, pchild, status)
if (status == 0) then
! set the child configuration number ! set the child configuration number
! !
call metablock_set_configuration(pchild, config(q,p)) call metablock_set_configuration(pchild, config(q,p))
! associate the parent's children array element with the freshly created ! associate the parent's children array element with the freshly created
! meta block ! meta block
! !
pmeta%child(order(q,p))%ptr => pchild pmeta%child(order(q,p))%ptr => pchild
end if
end do ! nchildren end do ! nchildren
@ -4009,12 +4014,13 @@ module blocks
! !
! Arguments: ! Arguments:
! !
! pmeta - the pointer associated with the newly appended meta block; ! pmeta - the pointer associated with the newly appended meta block;
! pprev - the pointer after which the new block has to be inserted; ! pprev - the pointer after which the new block has to be inserted;
! status - the flag indicating success or failure;
! !
!=============================================================================== !===============================================================================
! !
subroutine insert_metablock_after(pprev, pmeta) subroutine insert_metablock_after(pprev, pmeta, status)
! import external procedures ! import external procedures
! !
@ -4028,10 +4034,7 @@ 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
integer , intent(out) :: status
! local variables
!
integer :: status
! local parameters ! local parameters
! !
@ -4061,34 +4064,25 @@ module blocks
if (associated(pprev%next)) pprev%next%prev => pmeta if (associated(pprev%next)) pprev%next%prev => pmeta
pprev%next => pmeta pprev%next => pmeta
! check if last_meta is associated
!
if (associated(last_meta)) then
! update the last_meta pointer if necessary ! update the last_meta pointer if necessary
! !
if (associated(last_meta)) then
if (pprev%id == last_meta%id) last_meta => pmeta if (pprev%id == last_meta%id) last_meta => pmeta
else else
! strange situation, pprev is associated, but last_meta not
!
write(error_unit,"('[',a,']: ',a)") trim(loc) & write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Argument pprev is associated but last_meta is not!" , "Argument pprev is associated but last_meta is not!"
status = 1
return
end if end if
else
! if pprev is null and list_meta is associated, there is something wrong ! if pprev is null and list_meta is associated, there is something wrong
! !
else
if (associated(list_meta)) then if (associated(list_meta)) then
! strange situation, pprev is null but list_meta is associated
!
write(error_unit,"('[',a,']: ',a)") trim(loc) & write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Argument pprev is null but list_meta is associated!" , "Argument pprev is null but list_meta is associated!"
status = 1
return
else else
! pprev and list_meta are nulls, so add the first block to the list by ! pprev and list_meta are nulls, so add the first block to the list by
@ -4120,12 +4114,13 @@ module blocks
! !
! Arguments: ! Arguments:
! !
! pmeta - the pointer associated with the newly appended meta block; ! pmeta - the pointer associated with the newly appended meta block;
! pnext - the pointer before which the new block has to be inserted; ! pnext - the pointer before which the new block has to be inserted;
! status - the flag indicating success or failure;
! !
!=============================================================================== !===============================================================================
! !
subroutine insert_metablock_before(pnext, pmeta) subroutine insert_metablock_before(pnext, pmeta, status)
! import external procedures ! import external procedures
! !
@ -4139,10 +4134,7 @@ 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
integer , intent(out) :: status
! local variables
!
integer :: status
! local parameters ! local parameters
! !
@ -4172,21 +4164,15 @@ module blocks
if (associated(pnext%prev)) pnext%prev%next => pmeta if (associated(pnext%prev)) pnext%prev%next => pmeta
pnext%prev => pmeta pnext%prev => pmeta
! check if list_meta is associated ! update the last_meta pointer if necessary
! !
if (associated(list_meta)) then if (associated(list_meta)) then
! update the list_meta pointer if necessary
!
if (pnext%id == list_meta%id) list_meta => pmeta if (pnext%id == list_meta%id) list_meta => pmeta
else else
! strange situation, pnext is associated, but list_meta not
!
write(error_unit,"('[',a,']: ',a)") trim(loc) & write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Argument pnext is associated but list_meta is not!" , "Argument pnext is associated but list_meta is not!"
status = 1
return
end if end if
else else
@ -4194,12 +4180,10 @@ module blocks
! if pnext is null and last_meta is associated, there is something wrong ! if pnext is null and last_meta is associated, there is something wrong
! !
if (associated(last_meta)) then if (associated(last_meta)) then
! strange situation, pnext is null but last_meta is associated
!
write(error_unit,"('[',a,']: ',a)") trim(loc) & write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Argument pnext is null but last_meta is associated!" , "Argument pnext is null but last_meta is associated!"
status = 1
return
else else
! pnext and last_meta are nulls, so add the first block to the list by ! pnext and last_meta are nulls, so add the first block to the list by