Changelog
 base/modules/psb_desc_type.f90

Make sure free and move_alloc can be called on an empty descriptor.
psblas-3.0-maint
Salvatore Filippone 13 years ago
parent 2203f7239c
commit 1fb18721ee

@ -1,6 +1,9 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. history.
2012/04/30: Change descriptor's move_alloc and free to work on
uninitialized input.
2012/04/15: New LOCAL argument to geins/spins. New LIDX argument to CDALL 2012/04/15: New LOCAL argument to geins/spins. New LIDX argument to CDALL
with VL to allow for user-specified local numbering. with VL to allow for user-specified local numbering.

@ -227,6 +227,7 @@ module psb_descriptor_type
procedure, pass(desc) :: get_list => psb_cd_get_list procedure, pass(desc) :: get_list => psb_cd_get_list
procedure, pass(desc) :: sizeof => psb_cd_sizeof procedure, pass(desc) :: sizeof => psb_cd_sizeof
procedure, pass(desc) :: free => psb_cdfree procedure, pass(desc) :: free => psb_cdfree
procedure, pass(desc) :: destroy => psb_cd_destroy
procedure, pass(desc) :: nullify => nullify_desc procedure, pass(desc) :: nullify => nullify_desc
end type psb_desc_type end type psb_desc_type
@ -630,126 +631,175 @@ contains
integer(psb_ipk_) :: ictxt,np,me, err_act integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'psb_cdfree' name = 'psb_cdfree'
if (desc%is_valid()) then call desc%destroy()
ictxt=psb_cd_get_context(desc)
call psb_info(ictxt, me, np) !!$ if (desc%is_valid()) then
! ....verify blacs grid correctness.. !!$ ictxt=psb_cd_get_context(desc)
if (np == -1) then !!$
info = psb_err_context_error_ !!$ call psb_info(ictxt, me, np)
call psb_errpush(info,name) !!$ ! ....verify blacs grid correctness..
goto 9999 !!$ if (np == -1) then
endif !!$ info = psb_err_context_error_
else !!$ call psb_errpush(info,name)
ictxt = -1 !!$ goto 9999
end if !!$ endif
!!$ else
if (.not.allocated(desc%halo_index)) then !!$ ictxt = -1
info=298 !!$ end if
call psb_errpush(info,name) !!$
goto 9999 !!$ if (.not.allocated(desc%halo_index)) then
end if !!$ info=298
!!$ call psb_errpush(info,name)
!deallocate halo_index field !!$ goto 9999
deallocate(desc%halo_index,stat=info) !!$ end if
if (info /= psb_success_) then !!$
info=2053 !!$ !deallocate halo_index field
call psb_errpush(info,name) !!$ deallocate(desc%halo_index,stat=info)
goto 9999 !!$ if (info /= psb_success_) then
end if !!$ info=2053
!!$ call psb_errpush(info,name)
if (.not.allocated(desc%bnd_elem)) then !!$ goto 9999
!!$ info=296 !!$ end if
!!$
!!$ if (.not.allocated(desc%bnd_elem)) then
!!$! !$ info=296
!!$! !$ call psb_errpush(info,name)
!!$! !$ goto 9999
!!$! !$ end if
!!$ else
!!$ !deallocate halo_index field
!!$ deallocate(desc%bnd_elem,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2054
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ end if
!!$
!!$ if (.not.allocated(desc%ovrlap_index)) then
!!$ info=299
!!$ call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$
!!$ !deallocate ovrlap_index field
!!$ deallocate(desc%ovrlap_index,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2055
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ !deallocate ovrlap_elem field
!!$ deallocate(desc%ovrlap_elem,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2056
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ !deallocate ovrlap_index field
!!$ deallocate(desc%ovr_mst_idx,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2055
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$
!!$ if (allocated(desc%lprm)) &
!!$ & deallocate(desc%lprm,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2057
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ if (allocated(desc%indxmap)) then
!!$ call desc%indxmap%free()
!!$ deallocate(desc%indxmap, stat=info)
!!$ end if
!!$ if (allocated(desc%idx_space)) then
!!$ deallocate(desc%idx_space,stat=info)
!!$ if (info /= psb_success_) then
!!$ info=2056
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ end if
!!$
!!$ call desc%nullify()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else else
!deallocate halo_index field if (ictxt == -1) then
deallocate(desc%bnd_elem,stat=info) call psb_error()
if (info /= psb_success_) then else
info=2054 call psb_error(ictxt)
call psb_errpush(info,name)
goto 9999
end if end if
end if end if
return
if (.not.allocated(desc%ovrlap_index)) then end subroutine psb_cdfree
info=299
call psb_errpush(info,name)
goto 9999
end if
!deallocate ovrlap_index field !
deallocate(desc%ovrlap_index,stat=info) ! Subroutine: psb_cdfree
if (info /= psb_success_) then ! Frees a descriptor data structure.
info=2055 !
call psb_errpush(info,name) ! Arguments:
goto 9999 ! desc_a - type(psb_desc_type). The communication descriptor to be freed.
end if subroutine psb_cd_destroy(desc)
!...free descriptor structure...
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
!....parameters...
class(psb_desc_type), intent(inout) :: desc
!...locals....
integer(psb_ipk_) :: info
!deallocate ovrlap_elem field
deallocate(desc%ovrlap_elem,stat=info)
if (info /= psb_success_) then
info=2056
call psb_errpush(info,name)
goto 9999
end if
!deallocate ovrlap_index field if (allocated(desc%halo_index)) &
deallocate(desc%ovr_mst_idx,stat=info) & deallocate(desc%halo_index,stat=info)
if (info /= psb_success_) then
info=2055 if (allocated(desc%bnd_elem)) &
call psb_errpush(info,name) & deallocate(desc%bnd_elem,stat=info)
goto 9999
end if
if (allocated(desc%ovrlap_index)) &
& deallocate(desc%ovrlap_index,stat=info)
if (allocated(desc%ovrlap_elem)) &
& deallocate(desc%ovrlap_elem,stat=info)
if (allocated(desc%ovr_mst_idx)) &
& deallocate(desc%ovr_mst_idx,stat=info)
if (allocated(desc%lprm)) & if (allocated(desc%lprm)) &
& deallocate(desc%lprm,stat=info) & deallocate(desc%lprm,stat=info)
if (info /= psb_success_) then if (allocated(desc%idx_space)) &
info=2057 & deallocate(desc%idx_space,stat=info)
call psb_errpush(info,name)
goto 9999
end if
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%free() call desc%indxmap%free()
deallocate(desc%indxmap, stat=info) deallocate(desc%indxmap, stat=info)
end if end if
if (allocated(desc%idx_space)) then
deallocate(desc%idx_space,stat=info)
if (info /= psb_success_) then
info=2056
call psb_errpush(info,name)
goto 9999
end if
end if
call desc%nullify() call desc%nullify()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
if (ictxt == -1) then
call psb_error()
else
call psb_error(ictxt)
end if
end if
return return
end subroutine psb_cdfree end subroutine psb_cd_destroy
! !
! Subroutine: psb_cdtransfer ! Subroutine: psb_cdtransfer
! Transfers data and allocation from in to out; behaves like MOVE_ALLOC, i.e. ! Transfers data and allocation from in to out; behaves like MOVE_ALLOC, i.e.

Loading…
Cancel
Save