fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-17 03:12:15 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
Changelog
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_i_tools_mod.f90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_s_tools_mod.f90
 base/tools/Makefile
 base/tools/psb_cd_inloc.f90
 base/tools/psb_cd_lstext.f90
 base/tools/psb_cd_reinit.f90
 base/tools/psb_cd_set_bld.f90
 base/tools/psb_cd_switch_ovl_indxmap.f90
 base/tools/psb_cdall.f90
 base/tools/psb_cdals.f90
 base/tools/psb_cdalv.f90
 base/tools/psb_cdcpy.F90
 base/tools/psb_cdins.f90
 base/tools/psb_cdren.f90
 base/tools/psb_cdrep.f90
 base/tools/psb_csprn.f90
 base/tools/psb_dsprn.f90
 base/tools/psb_get_overlap.f90
 base/tools/psb_glob_to_loc.f90
 base/tools/psb_ialloc.f90
 base/tools/psb_iasb.f90
 base/tools/psb_icdasb.F90
 base/tools/psb_ifree.f90
 base/tools/psb_iins.f90
 base/tools/psb_loc_to_glob.f90
 base/tools/psb_ssprn.f90
 base/tools/psb_zsprn.f90

New error handling
This commit is contained in:
Salvatore Filippone
2014-12-21 11:56:07 +00:00
parent d4406cc6cf
commit b8ed1439d0
30 changed files with 806 additions and 858 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Changelog
+4
View File
@@ -1,5 +1,9 @@
Changelog. A lot less detailed than usual, at least for past
history.
2014/12/21: Change error handling routines to make them more flexible for
C binding. More compact prologues/epilogues.
2014/11/12: Fix silly bug in MMIO: cycling through rank-2 dense read/write was
transposing!
2014/10/22: Implement norm-1 and norm-infinity at base_sparse_mat relying
base/modules/psb_i_base_vect_mod.f90
+34 -3
View File
@@ -75,7 +75,9 @@ module psb_i_base_vect_mod
! Assembly does almost nothing here, but is important
! in derived classes.
!
procedure, pass(x) :: ins => i_base_ins
procedure, pass(x) :: ins_a => i_base_ins_a
procedure, pass(x) :: ins_v => i_base_ins_v
generic, public :: ins => ins_a, ins_v
procedure, pass(x) :: zero => i_base_zero
procedure, pass(x) :: asb => i_base_asb
procedure, pass(x) :: free => i_base_free
@@ -295,7 +297,7 @@ contains
!! \param info return code
!!
!
subroutine i_base_ins(n,irl,val,dupl,x,info)
subroutine i_base_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
@@ -346,12 +348,41 @@ contains
! !$ goto 9999
end select
end if
call x%set_host()
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
return
end if
end subroutine i_base_ins
end subroutine i_base_ins_a
subroutine i_base_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_base_vect_type), intent(inout) :: irl
class(psb_i_base_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, isz
info = 0
if (psb_errstatus_fatal()) return
if (irl%is_dev()) call irl%sync()
if (val%is_dev()) call val%sync()
if (x%is_dev()) call x%sync()
call x%ins(n,irl%v,val%v,dupl,info)
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
return
end if
end subroutine i_base_ins_v
!
!> Function base_zero
base/modules/psb_i_tools_mod.f90
+48
View File
@@ -57,6 +57,14 @@ module psb_i_tools_mod
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
end subroutine psb_ialloc_vect
subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_i_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
end subroutine psb_ialloc_vect_r2
end interface
@@ -82,6 +90,15 @@ module psb_i_tools_mod
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info,mold, scratch)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
end subroutine psb_iasb_vect_r2
end interface
@@ -105,6 +122,13 @@ module psb_i_tools_mod
type(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ifree_vect
subroutine psb_ifree_vect_r2(x, desc_a, info)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ifree_vect_r2
end interface
interface psb_geins
@@ -142,6 +166,30 @@ module psb_i_tools_mod
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect
subroutine psb_iins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: irw
type(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect_v
subroutine psb_iins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect_r2
end interface
base/modules/psb_i_vect_mod.F90
+25 -3
View File
@@ -76,7 +76,9 @@ module psb_i_vect_mod
procedure, pass(y) :: sctb => i_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => i_vect_free
procedure, pass(x) :: ins => i_vect_ins
procedure, pass(x) :: ins_a => i_vect_ins_a
procedure, pass(x) :: ins_v => i_vect_ins_v
generic, public :: ins => ins_v, ins_a
procedure, pass(x) :: bld_x => i_vect_bld_x
procedure, pass(x) :: bld_n => i_vect_bld_n
generic, public :: bld => bld_x, bld_n
@@ -609,7 +611,7 @@ contains
end subroutine i_vect_free
subroutine i_vect_ins(n,irl,val,dupl,x,info)
subroutine i_vect_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
@@ -628,8 +630,28 @@ contains
call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins
end subroutine i_vect_ins_a
subroutine i_vect_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_vect_type), intent(inout) :: irl
class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine i_vect_ins_v
subroutine i_vect_cnv(x,mold)
class(psb_i_vect_type), intent(inout) :: x
base/modules/psb_s_tools_mod.f90
+1 -1
View File
@@ -22,7 +22,7 @@
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSIESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
base/tools/Makefile
+1 -1
View File
@@ -11,7 +11,7 @@ FOBJS = psb_sallc.o psb_sasb.o \
psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_sspalloc.o psb_sspasb.o \
psb_sspfree.o psb_sspins.o psb_ssprn.o\
psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \
psb_glob_to_loc.o psb_iallc.o psb_iasb.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o\
psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \
psb_zspalloc.o psb_zspasb.o psb_zspfree.o\
base/tools/psb_cd_inloc.f90
+2 -6
View File
@@ -385,12 +385,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cd_inloc
base/tools/psb_cd_lstext.f90
+3 -7
View File
@@ -153,12 +153,8 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_cd_lstext
base/tools/psb_cd_reinit.f90
+3 -7
View File
@@ -77,12 +77,8 @@ Subroutine psb_cd_reinit(desc,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_cd_reinit
base/tools/psb_cd_set_bld.f90
+2 -7
View File
@@ -80,13 +80,8 @@ subroutine psb_cd_set_bld(desc,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cd_set_bld
base/tools/psb_cd_switch_ovl_indxmap.f90
+3 -7
View File
@@ -127,13 +127,9 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_cd_switch_ovl_indxmap
base/tools/psb_cdall.f90
+11 -16
View File
@@ -65,7 +65,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
& present(parts),present(nl), present(repl) /)) /= 1) then
info=psb_err_no_optional_arg_
call psb_errpush(info,name,a_err=" vg, vl, parts, nl, repl")
goto 999
goto 9999
endif
desc%base_desc => null()
@@ -78,7 +78,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (.not.present(mg)) then
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
goto 9999
end if
if (present(ng)) then
n_ = ng
@@ -92,12 +92,12 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (.not.present(mg)) then
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
goto 9999
end if
if (.not.repl) then
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
goto 9999
end if
call psb_cdrep(mg, ictxt, desc, info)
@@ -145,21 +145,21 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
class default
! This cannot happen
info = psb_err_internal_error_
goto 999
goto 9999
end select
end if
call psb_realloc(1,itmpsz, info)
if (info /= 0) then
write(0,*) 'Error reallocating itmspz'
goto 999
goto 9999
end if
itmpsz(:) = -1
call psi_bld_tmpovrl(itmpsz,desc,info)
endif
if (info /= psb_success_) goto 999
if (info /= psb_success_) goto 9999
! Finish off
lr = desc%indxmap%get_lr()
@@ -168,23 +168,18 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
Goto 999
Goto 9999
end if
desc%halo_index(:) = -1
desc%ext_index(:) = -1
call psb_cd_set_bld(desc,info)
if (info /= psb_success_) goto 999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cdall
base/tools/psb_cdals.f90
+2 -6
View File
@@ -284,12 +284,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cdals
base/tools/psb_cdalv.f90
+2 -6
View File
@@ -215,12 +215,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cdalv
base/tools/psb_cdcpy.F90
+1 -7
View File
@@ -86,14 +86,8 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cdcpy
base/tools/psb_cdins.f90
+2 -14
View File
@@ -142,14 +142,8 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cdinsrc
@@ -264,14 +258,8 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cdinsc
base/tools/psb_cdren.f90
+1 -7
View File
@@ -153,14 +153,8 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cdren
base/tools/psb_cdrep.f90
+2 -7
View File
@@ -216,12 +216,7 @@ subroutine psb_cdrep(m, ictxt, desc, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cdrep
base/tools/psb_csprn.f90
+2 -6
View File
@@ -91,12 +91,8 @@ Subroutine psb_csprn(a, desc_a,info,clear)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_csprn
base/tools/psb_dsprn.f90
+6 -15
View File
@@ -41,6 +41,7 @@
! info - integer. Return code.
! clear - logical, optional Whether the coefficients should be zeroed
! default .true.
!
Subroutine psb_dsprn(a, desc_a,info,clear)
use psb_base_mod, psb_protect_name => psb_dsprn
Implicit None
@@ -59,29 +60,23 @@ Subroutine psb_dsprn(a, desc_a,info,clear)
logical :: clear_
info = psb_success_
if (psb_errstatus_fatal()) return
err = 0
int_err(1)=0
name = 'psb_dsprn'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': start '
if (a%is_bld()) then
if (psb_is_bld_desc(desc_a)) then
! Should do nothing, we are called redundantly
return
endif
if (.not.a%is_asb()) then
if (.not.psb_is_asb_desc(desc_a)) then
info=590
call psb_errpush(info,name)
goto 9999
@@ -89,19 +84,15 @@ Subroutine psb_dsprn(a, desc_a,info,clear)
call a%reinit(clear=clear)
if (psb_errstatus_fatal()) goto 9999
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dsprn
base/tools/psb_get_overlap.f90
+2 -6
View File
@@ -92,12 +92,8 @@ subroutine psb_get_ovrlap(ovrel,desc,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
9999 call psb_error_handler(err_act)
return
end subroutine psb_get_ovrlap
base/tools/psb_glob_to_loc.f90
+2 -15
View File
@@ -114,17 +114,10 @@ subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_glob_to_loc2v
@@ -238,14 +231,8 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_glob_to_loc1v
base/tools/psb_ialloc.f90
-330
View File
@@ -1,330 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_ialloc.f90
!
! Function: psb_ialloc
! Allocates dense integer matrix for PSBLAS routines
! The descriptor may be in either the build or assembled state.
!
! Arguments:
! x - the matrix to be allocated.
! desc_a - the communication descriptor.
! info - possibly returns an error code
! n - optional number of columns.
! lb - optional lower bound on column indices
subroutine psb_ialloc(x, desc_a, info, n, lb)
use psb_base_mod, psb_protect_name => psb_ialloc
implicit none
!....parameters...
integer(psb_ipk_), allocatable, intent(out) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
!locals
integer(psb_ipk_) :: np,me,err,nr,i,j,err_act
integer(psb_ipk_) :: ictxt,n_
integer(psb_ipk_) :: int_err(5), exch(3)
character(len=20) :: name
name='psb_geall'
if(psb_get_errstatus() /= 0) return
info=psb_success_
err=0
int_err(1)=0
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
if (present(n)) then
n_ = n
else
n_ = 1
endif
!global check on n parameters
if (me == psb_root_) then
exch(1)=n_
call psb_bcast(ictxt,exch(1),root=psb_root_)
else
call psb_bcast(ictxt,exch(1),root=psb_root_)
if (exch(1) /= n_) then
info=psb_err_parm_differs_among_procs_
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
int_err(1)=nr*n_
call psb_errpush(info,name,int_err,a_err='integer')
goto 9999
endif
x(:,:) = izero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_ialloc
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Function: psb_iallocv
! Allocates dense matrix for PSBLAS routines
! The descriptor may be in either the build or assembled state.
!
! Arguments:
! x(:) - the matrix to be allocated.
! desc_a - the communication descriptor.
! info - return code
subroutine psb_iallocv(x, desc_a, info,n)
use psb_base_mod, psb_protect_name => psb_iallocv
implicit none
!....parameters...
integer(psb_ipk_), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: ictxt, int_err(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='integer')
goto 9999
endif
x(:) = izero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_iallocv
subroutine psb_ialloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_ialloc_vect
use psi_mod
implicit none
!....parameters...
type(psb_i_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: ictxt, int_err(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
allocate(psb_i_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)')
goto 9999
endif
call x%zero()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_ialloc_vect
base/tools/psb_iasb.f90
+111 -41
View File
@@ -39,22 +39,22 @@
! We also call the halo routine for good measure.
!
! Arguments:
! x(:,:) - integer(psb_ipk_),allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! x(:,:) - integer, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
subroutine psb_iasb(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_iasb
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(inout) :: x(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
! local variables
integer(psb_ipk_) :: ictxt,np,me,nrow,ncol,err_act
integer(psb_ipk_) :: int_err(5), i1sz, i2sz
integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act
integer(psb_ipk_) :: i1sz, i2sz
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=psb_success_
@@ -83,8 +83,7 @@ subroutine psb_iasb(x, desc_a, info)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' error ',&
& desc_a%get_dectype()
& write(debug_unit,*) me,' ',trim(name),' error '
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
@@ -107,7 +106,7 @@ subroutine psb_iasb(x, desc_a, info)
goto 9999
endif
endif
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@@ -122,16 +121,11 @@ subroutine psb_iasb(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_iasb
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iasb
!!$
@@ -165,7 +159,7 @@ end subroutine psb_iasb
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Subroutine: psb_iasbv
! Subroutine: psb_iasb
! Assembles a dense matrix for PSBLAS routines
! Since the allocation may have been called with the desciptor
! in the build state we make sure that X has a number of rows
@@ -173,16 +167,16 @@ end subroutine psb_iasb
! We also call the halo routine for good measure.
!
! Arguments:
! x(:) - integer(psb_ipk_),allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! x(:) - integer, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_iasbv(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_iasbv
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
! local variables
integer(psb_ipk_) :: ictxt,np,me
@@ -225,8 +219,8 @@ subroutine psb_iasbv(x, desc_a, info)
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
endif
endif
endif
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
@@ -241,14 +235,10 @@ subroutine psb_iasbv(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iasbv
@@ -321,12 +311,92 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iasb_vect
subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_iasb_vect_r2
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me, i, n
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
info = psb_success_
if (psb_errstatus_fatal()) return
int_err(1) = 0
name = 'psb_igeasb_v'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
call x(i)%asb(ncol,info)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
if (present(mold)) then
call x(i)%cnv(mold)
end if
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iasb_vect_r2
base/tools/psb_icdasb.F90
+1 -7
View File
@@ -168,14 +168,8 @@ subroutine psb_icdasb(desc,info,ext_hv,mold)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_icdasb
base/tools/psb_ifree.f90
+91 -84
View File
@@ -32,21 +32,21 @@
! File: psb_ifree.f90
!
! Subroutine: psb_ifree
! frees a dense integer matrix structure
! frees a dense matrix structure
!
! Arguments:
! x(:,:) - integer(psb_ipk_), allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Eventually returns an error code
! x(:,:) - integer, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_ifree(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_ifree
implicit none
!....parameters...
integer(psb_ipk_), allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -55,12 +55,11 @@ subroutine psb_ifree(x, desc_a, info)
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_ifree'
name='psb_ifree'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
end if
ictxt=desc_a%get_context()
@@ -74,79 +73,46 @@ subroutine psb_ifree(x, desc_a, info)
endif
if (.not.allocated(x)) then
info=psb_err_forgot_geall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
deallocate(x,stat=info)
if (info /= psb_success_) then
info=2045
call psb_errpush(info,name)
goto 9999
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_ifree
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Subroutine: psb_ifreev
! frees a dense integer matrix structure
! frees a dense matrix structure
!
! Arguments:
! x(:) - integer(psb_ipk_), allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Eventually returns an error code
subroutine psb_ifreev(x, desc_a,info)
! x(:) - integer, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_ifreev(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_ifreev
implicit none
!....parameters...
integer(psb_ipk_), allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -155,26 +121,26 @@ subroutine psb_ifreev(x, desc_a,info)
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_ifreev'
name='psb_ifreev'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
goto 9999
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x)) then
info=psb_err_forgot_geall_
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
@@ -189,17 +155,12 @@ subroutine psb_ifreev(x, desc_a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_ifreev
subroutine psb_ifree_vect(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_ifree_vect
implicit none
@@ -248,13 +209,59 @@ subroutine psb_ifree_vect(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_ifree_vect
subroutine psb_ifree_vect_r2(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_ifree_vect_r2
implicit none
!....parameters...
type(psb_i_vect_type), allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act, i
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name='psb_ifreev'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
do i=lbound(x,1),ubound(x,1)
call x(i)%free(info)
if (info /= 0) exit
end do
if (info == 0) deallocate(x,stat=info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_ifree_vect_r2
base/tools/psb_iins.f90
+437 -223
View File
@@ -51,17 +51,18 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_),intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_),intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
@@ -75,13 +76,14 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_insvi'
name = 'psb_iinsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
return
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
@@ -117,7 +119,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -153,8 +155,8 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
!loop over all val's rows
if (irl(i) > 0) then
! this row belongs to me
! copy i-th row of block val in x
! this row belongs to me
! copy i-th row of block val in x
x(irl(i)) = x(irl(i)) + val(i)
end if
enddo
@@ -169,216 +171,13 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_iinsvi
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Subroutine: psb_iinsi
! Insert dense submatrix to dense matrix. Note: the row indices in IRW
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process are silently discarded.
!
! Arguments:
! m - integer. Number of rows of submatrix belonging to
! val to be inserted.
! irw(:) - integer Row indices of rows of val (global numbering)
! val(:,:) - integer The source dense submatrix.
! x(:,:) - integer The destination dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iinsi
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_),intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,loc_row,j,n,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np,me,dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_iinsi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
return
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1) < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
n = min(size(val,2),size(x,2))
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = val(i,j)
end do
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = x(loc_row,j) + val(i,j)
end do
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_iinsi
subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iins_vect
use psi_mod
@@ -460,7 +259,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -487,15 +286,430 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_iins_vect
subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_i_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
integer(psb_ipk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_iinsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iins_vect_v
subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iins_vect_r2
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
type(psb_i_vect_type), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5), n
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_iinsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x(1)%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x(1)%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
n = min(size(x),size(val,2))
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit
end do
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iins_vect_r2
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Subroutine: psb_iinsi
! Insert dense submatrix to dense matrix. Note: the row indices in IRW
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process are silently discarded.
!
! Arguments:
! m - integer. Number of rows of submatrix belonging to
! val to be inserted.
! irw(:) - integer Row indices of rows of val (global numbering)
! val(:,:) - integer The source dense submatrix.
! x(:,:) - integer The destination dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iinsi
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_),intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,loc_row,j,n,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np,me,dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_iinsi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
return
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1) < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
n = min(size(val,2),size(x,2))
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = val(i,j)
end do
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = x(loc_row,j) + val(i,j)
end do
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_iinsi
base/tools/psb_loc_to_glob.f90
+2 -14
View File
@@ -99,14 +99,8 @@ subroutine psb_loc_to_glob2v(x,y,desc_a,info,iact)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_loc_to_glob2v
@@ -209,14 +203,8 @@ subroutine psb_loc_to_glob1v(x,desc_a,info,iact)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_loc_to_glob1v
base/tools/psb_ssprn.f90
+3 -6
View File
@@ -41,6 +41,7 @@
! info - integer. Return code.
! clear - logical, optional Whether the coefficients should be zeroed
! default .true.
!
Subroutine psb_ssprn(a, desc_a,info,clear)
use psb_base_mod, psb_protect_name => psb_ssprn
Implicit None
@@ -90,12 +91,8 @@ Subroutine psb_ssprn(a, desc_a,info,clear)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_ssprn
base/tools/psb_zsprn.f90
+2 -6
View File
@@ -91,12 +91,8 @@ Subroutine psb_zsprn(a, desc_a,info,clear)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zsprn