BLOCKS: Add status argument to insert_metablock_after/before().
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
parent
5caf3f37cf
commit
4e688b8fcd
@ -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
|
||||||
|
Loading…
x
Reference in New Issue
Block a user