diff --git a/Changelog b/Changelog index 9802b0f9..e2707536 100644 --- a/Changelog +++ b/Changelog @@ -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 diff --git a/base/modules/psb_i_base_vect_mod.f90 b/base/modules/psb_i_base_vect_mod.f90 index 900b45f2..4380efc9 100644 --- a/base/modules/psb_i_base_vect_mod.f90 +++ b/base/modules/psb_i_base_vect_mod.f90 @@ -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 diff --git a/base/modules/psb_i_tools_mod.f90 b/base/modules/psb_i_tools_mod.f90 index 4ff63452..b46da2f3 100644 --- a/base/modules/psb_i_tools_mod.f90 +++ b/base/modules/psb_i_tools_mod.f90 @@ -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 diff --git a/base/modules/psb_i_vect_mod.F90 b/base/modules/psb_i_vect_mod.F90 index ae8c2a86..48059940 100644 --- a/base/modules/psb_i_vect_mod.F90 +++ b/base/modules/psb_i_vect_mod.F90 @@ -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 diff --git a/base/modules/psb_s_tools_mod.f90 b/base/modules/psb_s_tools_mod.f90 index 99ebdf53..b0612cc8 100644 --- a/base/modules/psb_s_tools_mod.f90 +++ b/base/modules/psb_s_tools_mod.f90 @@ -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 diff --git a/base/tools/Makefile b/base/tools/Makefile index 1a87195e..c9d4cf8a 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -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\ diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 7bfe1819..6dc39eb3 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -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 diff --git a/base/tools/psb_cd_lstext.f90 b/base/tools/psb_cd_lstext.f90 index 3cf99e78..a97113db 100644 --- a/base/tools/psb_cd_lstext.f90 +++ b/base/tools/psb_cd_lstext.f90 @@ -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 diff --git a/base/tools/psb_cd_reinit.f90 b/base/tools/psb_cd_reinit.f90 index d3285ae2..5d650ffd 100644 --- a/base/tools/psb_cd_reinit.f90 +++ b/base/tools/psb_cd_reinit.f90 @@ -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 diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index fea351f2..f91696e0 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -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 diff --git a/base/tools/psb_cd_switch_ovl_indxmap.f90 b/base/tools/psb_cd_switch_ovl_indxmap.f90 index c7370214..86a4d49b 100644 --- a/base/tools/psb_cd_switch_ovl_indxmap.f90 +++ b/base/tools/psb_cd_switch_ovl_indxmap.f90 @@ -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 diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index f3190595..46aa9d44 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -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 diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index bc03b0d1..7fbdc0ae 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -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 diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index a7be785d..be1b9900 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -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 diff --git a/base/tools/psb_cdcpy.F90 b/base/tools/psb_cdcpy.F90 index 3112139a..12a3240a 100644 --- a/base/tools/psb_cdcpy.F90 +++ b/base/tools/psb_cdcpy.F90 @@ -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 diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index 71baa89a..72eedd1d 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -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 diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index 31c7e2d7..d31f41fb 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -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 diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index e7b06fbd..248ed4da 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -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 diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 index af6a1cf8..98eb9bb2 100644 --- a/base/tools/psb_csprn.f90 +++ b/base/tools/psb_csprn.f90 @@ -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 diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index 6ed21d3b..c9918935 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -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 diff --git a/base/tools/psb_get_overlap.f90 b/base/tools/psb_get_overlap.f90 index 46a13ee0..6d529e6d 100644 --- a/base/tools/psb_get_overlap.f90 +++ b/base/tools/psb_get_overlap.f90 @@ -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 diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index b2f3a353..603710b0 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -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 diff --git a/base/tools/psb_ialloc.f90 b/base/tools/psb_ialloc.f90 deleted file mode 100644 index c24f248e..00000000 --- a/base/tools/psb_ialloc.f90 +++ /dev/null @@ -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 - diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 1f639f75..3f6db8ab 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -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 +9999 call psb_error_handler(ictxt,err_act) + return - -end subroutine psb_iasb +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 diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index ca0cb4d3..9622fca4 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -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 diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index d709cb36..f205324d 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -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 diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 44b6f695..47215996 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -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,17 +171,356 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 continue +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_iinsvi + + +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 + 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) + 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 + + !... 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 + + + + 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 + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + call psb_erractionrestore(err_act) + return - if (err_act == psb_act_ret_) then - return +9999 call psb_error_handler(ictxt,err_act) + + 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 - call psb_error(ictxt) + 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 -end subroutine psb_iinsvi +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 + !!$ @@ -242,8 +583,8 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) !....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(:,:) + 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 @@ -267,6 +608,7 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_errpush(info,name) return end if + ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -310,7 +652,6 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_errpush(info,name) goto 9999 endif - if (present(local)) then local_ = local else @@ -365,137 +706,10 @@ subroutine psb_iinsi(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_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 - 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) - 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 - - !... 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 - - - - 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 - call x%ins(m,irl,val,dupl_,info) - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - 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_iins_vect - diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 67e07409..c87a65d0 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -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 diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 index 77d2905b..c6c2a214 100644 --- a/base/tools/psb_ssprn.f90 +++ b/base/tools/psb_ssprn.f90 @@ -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 diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index 96d4bb6b..6699564d 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -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