diff --git a/base/modules/parts.fh b/base/modules/parts.fh index 10e323d0..201bc79f 100644 --- a/base/modules/parts.fh +++ b/base/modules/parts.fh @@ -1,7 +1,8 @@ interface !.....user passed subroutine..... subroutine parts(glob_index,nrow,np,pv,nv) - integer, intent (in) :: glob_index,np,nrow - integer, intent (out) :: nv, pv(*) + import :: psb_ipk_ + integer(psb_ipk_), intent (in) :: glob_index,np,nrow + integer(psb_ipk_), intent (out) :: nv, pv(*) end subroutine parts end interface diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 418c4cb6..31bd5c07 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -59,16 +59,17 @@ module psb_const_mod ! ! Version ! - character(len=*), parameter :: psb_version_string_ = "3.0.0" - integer(psb_ipk_), parameter :: psb_version_major_ = 3 - integer(psb_ipk_), parameter :: psb_version_minor_ = 0 - integer(psb_ipk_), parameter :: psb_patchlevel_ = 0 + character(len=*), parameter :: psb_version_string_ = "3.0.0" + integer(psb_ipk_), parameter :: psb_version_major_ = 3 + integer(psb_ipk_), parameter :: psb_version_minor_ = 0 + integer(psb_ipk_), parameter :: psb_patchlevel_ = 0 ! ! Handy & miscellaneous constants ! - integer(psb_ipk_), parameter :: izero=0, ione=1 - integer(psb_ipk_), parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0 + integer(psb_ipk_), parameter :: izero=0, ione=1 + integer(psb_ipk_), parameter :: itwo=2, ithree=3,mone=-1 + integer(psb_ipk_), parameter :: psb_root_=0 real(psb_spk_), parameter :: szero=0.e0, sone=1.e0 real(psb_dpk_), parameter :: dzero=0.d0, done=1.d0 complex(psb_spk_), parameter :: czero=(0.e0,0.0e0) diff --git a/base/modules/psi_bcast_mod.F90 b/base/modules/psi_bcast_mod.F90 index a1dccb18..09936aec 100644 --- a/base/modules/psi_bcast_mod.F90 +++ b/base/modules/psi_bcast_mod.F90 @@ -9,8 +9,25 @@ module psi_bcast_mod & psb_zbcasts, psb_zbcastv, psb_zbcastm,& & psb_sbcasts, psb_sbcastv, psb_sbcastm,& & psb_cbcasts, psb_cbcastv, psb_cbcastm,& - & psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv - end interface + & psb_hbcasts, psb_hbcastv,& + & psb_lbcasts, psb_lbcastv + end interface psb_bcast + +#if defined(LONG_INTEGERS) + interface psb_bcast + module procedure psb_ibcasts_ic, psb_ibcastv_ic, psb_ibcastm_ic,& + & psb_dbcasts_ic, psb_dbcastv_ic, psb_dbcastm_ic,& + & psb_zbcasts_ic, psb_zbcastv_ic, psb_zbcastm_ic,& + & psb_sbcasts_ic, psb_sbcastv_ic, psb_sbcastm_ic,& + & psb_cbcasts_ic, psb_cbcastv_ic, psb_cbcastm_ic,& + & psb_hbcasts_ic, psb_hbcastv_ic, & + & psb_lbcasts_ic, psb_lbcastv_ic + end interface psb_bcast +#else + interface psb_bcast + module procedure psb_i8bcasts, psb_i8bcastv, psb_i8bcastm + end interface psb_bcast +#endif contains @@ -535,4 +552,420 @@ contains end subroutine psb_lbcastv + +#if !defined(LONG_INTEGERS) + + subroutine psb_i8bcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer(psb_mpik_), intent(in), optional :: root + + integer(psb_mpik_) :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,mpi_integer8,root_,ictxt,info) +#endif + end subroutine psb_i8bcasts + + subroutine psb_i8bcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer(psb_mpik_), intent(in), optional :: root + + integer(psb_mpik_) :: iam, np, root_, info +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_integer8,root_,ictxt,info) +#endif + end subroutine psb_ibcastv + + subroutine psb_ibcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer(psb_mpik_), intent(in), optional :: root + + integer(psb_mpik_) :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_integer8,root_,ictxt,info) +#endif + end subroutine psb_ibcastm + +#endif + + +#if defined(LONG_INTEGERS) + + subroutine psb_ibcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_ibcasts_ic + + subroutine psb_ibcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_ibcastv_ic + + subroutine psb_ibcastm_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(inout) :: dat(:,:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_ibcastm_ic + + + subroutine psb_sbcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_sbcasts_ic + + + subroutine psb_sbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_sbcastv_ic + + subroutine psb_sbcastm_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_sbcastm_ic + + + subroutine psb_dbcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_dbcasts_ic + + + subroutine psb_dbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_dbcastv_ic + + subroutine psb_dbcastm_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_dbcastm_ic + + subroutine psb_cbcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_cbcasts_ic + + subroutine psb_cbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_cbcastv_ic + + subroutine psb_cbcastm_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_cbcastm_ic + + subroutine psb_zbcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_zbcasts_ic + + subroutine psb_zbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_zbcastv_ic + + subroutine psb_zbcastm_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_zbcastm_ic + + + subroutine psb_hbcasts_ic(ictxt,dat,root,length) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root,length + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_hbcasts_ic + + subroutine psb_hbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_hbcastv_ic + + subroutine psb_lbcasts_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + logical, intent(inout) :: dat + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_lbcasts_ic + + + subroutine psb_lbcastv_ic(ictxt,dat,root) + implicit none + integer(psb_ipk_), intent(in) :: ictxt + logical, intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + + integer(psb_mpik_) :: iictxt, root_ + + iictxt = ictxt + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call psb_bcast(iictxt,dat,root_) + end subroutine psb_lbcastv_ic +#endif + + end module psi_bcast_mod diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index 054bda7e..e04802da 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -80,16 +80,15 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in),optional :: extype - ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& + integer(psb_ipk_) :: i, j, err_act,m,& + & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_ipk_) :: icomm, err_act + integer(psb_mpik_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -97,14 +96,21 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & t_halo_out(:),temp(:),maskr(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err name='psb_ccdbldext' info = psb_success_ + if (psb_errstatus_fatal()) return 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() icomm = desc_a%get_mpic() Call psb_info(ictxt, me, np) @@ -125,17 +131,17 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (novr<0) then info=psb_err_iarg_neg_ - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) + ierr(1)=1; ierr(2)=novr + call psb_errpush(info,name,i_err=ierr) goto 9999 endif select case(extype_) case(psb_ovt_xhal_,psb_ovt_asov_) case default + ierr(1)=5; ierr(2)=extype_ call psb_errpush(psb_err_input_value_invalid_i_,& - & name,i_err=(/5,extype_,0,0,0/)) + & name,i_err=ierr) goto 9999 end select @@ -144,10 +150,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= psb_success_) then + + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_cdcpy') goto 9999 end if @@ -220,15 +226,12 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& + if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),& + & tmp_ovr_idx(l_tmp_ovr_idx), & & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) + if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -257,7 +260,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -358,7 +361,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -370,7 +373,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+2) = gidx tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 - call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -402,7 +405,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -464,11 +467,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoall') goto 9999 end if idxs = 0 @@ -491,21 +493,20 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if lworkr = max(iszr,1) end if call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,& - & workr,rvsz,brvindx,psb_mpi_integer,icomm,info) - if (info /= psb_success_) then + & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoallv') goto 9999 end if @@ -561,7 +562,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! proc_id = temp(i) - call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) + call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -622,7 +623,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) - call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -649,7 +650,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call desc_ov%indxmap%set_lr(n_col_prev) - call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -667,7 +668,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) + ierr(1)=5; ierr(2)=extype_ + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select @@ -693,10 +695,12 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if ((info == psb_success_).and.allocated(icol)) & + & deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='deallocate',i_err=(/info,0,0,0,0/)) + ierr(1) = info + call psb_errpush(psb_err_from_subroutine_ai_,name, & + & a_err='deallocate',i_err=ierr) goto 9999 end if end if diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index c57ec03c..f6a23215 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -62,9 +62,10 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) integer(psb_ipk_) :: int_err(5),exch(3) integer(psb_ipk_), allocatable :: temp_ovrlap(:), tmpgidx(:,:), vl(:),& & nov(:), ov_idx(:,:) - integer(psb_ipk_) :: debug_level, debug_unit - logical :: check_, islarge - character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_mpik_) :: iictxt + logical :: check_, islarge + character(len=20) :: name if(psb_get_errstatus() /= 0) return info=psb_success_ @@ -77,7 +78,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) call psb_info(ictxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': start',np - + iictxt = ictxt loc_row = size(v) if (.false.) then @@ -325,7 +326,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (ov_idx(j,1) == i) exit j = j + 1 end do - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) + call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -353,9 +354,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(iictxt,m,info) class default - call aa%init(ictxt,vl(1:nlu),info) + call aa%init(iictxt,vl(1:nlu),info) end select call psi_bld_tmpovrl(temp_ovrlap,desc,info) @@ -371,31 +372,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) goto 9999 endif -!!$ ! set fields in desc%MATRIX_DATA.... -!!$ desc%matrix_data(psb_n_row_) = loc_row -!!$ desc%matrix_data(psb_n_col_) = loc_row - -!!$ call psb_realloc(max(1,loc_row/2),desc%halo_index, info) -!!$ if (info == psb_success_) call psb_realloc(1,desc%ext_index, info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ Goto 9999 -!!$ end if -!!$ desc%matrix_data(psb_pnt_h_) = 1 -!!$ desc%halo_index(:) = -1 -!!$ desc%ext_index(:) = -1 -!!$ -!!$ if (debug_level >= psb_debug_ext_) & -!!$ & write(debug_unit,*) me,' ',trim(name),': end' -!!$ -!!$ call psb_cd_set_bld(desc,info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_cd_set_bld') -!!$ Goto 9999 -!!$ end if - call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index ae4e54ca..cbc54db9 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -49,8 +49,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche character(len=20) :: name integer(psb_ipk_) :: err_act, n_, flag_, i, me, np, nlp, nnv, lr integer(psb_ipk_), allocatable :: itmpsz(:) - - + integer(psb_mpik_) :: iictxt + + if (psb_get_errstatus() /= 0) return info=psb_success_ @@ -58,7 +59,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche call psb_erractionsave(err_act) call psb_info(ictxt, me, np) - + iictxt = ictxt if (count((/ present(vg),present(vl),& & present(parts),present(nl), present(repl) /)) /= 1) then info=psb_err_no_optional_arg_ @@ -137,9 +138,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche if (info == psb_success_) then select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,nl,info) + call aa%repl_map_init(iictxt,nl,info) type is (psb_gen_block_map) - call aa%gen_block_map_init(ictxt,nl,info) + call aa%gen_block_map_init(iictxt,nl,info) class default ! This cannot happen info = psb_err_internal_error_ diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index fa4ae30a..0d4bd8da 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -62,6 +62,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) integer(psb_ipk_) :: int_err(5),exch(3) integer(psb_ipk_), allocatable :: prc_v(:), temp_ovrlap(:), loc_idx(:) integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_mpik_) :: iictxt character(len=20) :: name if(psb_get_errstatus() /= 0) return @@ -76,21 +77,20 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_info(ictxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np + iictxt = ictxt ! ....verify blacs grid correctness.. - + !... check m and n parameters.... if (m < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 1 - int_err(2) = m + int_err(1) = 1; int_err(2) = m; call psb_errpush(err,name,int_err) goto 9999 else if (n < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 2 - int_err(2) = n + int_err(1) = 2 ; int_err(2) = n; call psb_errpush(err,name,int_err) goto 9999 endif @@ -100,9 +100,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) & write(debug_unit,*) me,' ',trim(name),': doing global checks' !global check on m and n parameters if (me == psb_root_) then - exch(1)=m - exch(2)=n - exch(3)=psb_cd_get_large_threshold() + exch(1)=m; exch(2)=n; exch(3)=psb_cd_get_large_threshold() call psb_bcast(ictxt,exch(1:3),root=psb_root_) else call psb_bcast(ictxt,exch(1:3),root=psb_root_) @@ -125,9 +123,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector -!!$ allocate(desc%matrix_data(psb_mdata_size_),& -!!$ & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) -!!$ desc%matrix_data(:) = 0 allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) if (info /= psb_success_) then @@ -229,7 +224,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (prc_v(j) == me) then ! this point belongs to me k = k + 1 - call psb_ensure_size((k+1),loc_idx,info,pad=-1) + call psb_ensure_size((k+1),loc_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -238,7 +233,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) loc_idx(k) = i if (nprocs > 1) then - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) + call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -269,9 +264,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(iictxt,m,info) class default - call aa%init(ictxt,loc_idx(1:k),info) + call aa%init(iictxt,loc_idx(1:k),info) end select @@ -289,16 +284,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) Goto 9999 endif -!!$ ! set fields in desc%MATRIX_DATA.... -!!$ desc%matrix_data(psb_n_row_) = loc_row -!!$ desc%matrix_data(psb_n_col_) = loc_row - -!!$ write(0,*) me,'CDALS: after init ', & -!!$ & desc%indxmap%get_gr(), & -!!$ & desc%indxmap%get_gc(), & -!!$ & desc%indxmap%get_lr(), & -!!$ & desc%indxmap%get_lc() - if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index fb85b202..877aca2e 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -63,7 +63,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) integer(psb_ipk_) :: int_err(5),exch(3) integer(psb_ipk_), allocatable :: temp_ovrlap(:) integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + integer(psb_mpik_) :: iictxt + character(len=20) :: name if(psb_get_errstatus() /= 0) return debug_unit = psb_get_debug_unit() @@ -75,7 +76,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) call psb_info(ictxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np,me - + iictxt = ictxt m = size(v) n = m !... check m and n parameters.... @@ -189,11 +190,11 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(iictxt,m,info) type is (psb_hash_map) - call aa%hash_map_init(ictxt,v,info) + call aa%hash_map_init(iictxt,v,info) type is (psb_glist_map) - call aa%glist_map_init(ictxt,v,info) + call aa%glist_map_init(iictxt,v,info) class default ! This cannot happen info = psb_err_internal_error_ diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index f331d783..563735b7 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -115,6 +115,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) integer(psb_ipk_) :: i,np,me,err,n,err_act integer(psb_ipk_) :: int_err(5),exch(2), thalo(1), tovr(1), text(1) integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_mpik_) :: iictxt character(len=20) :: name if(psb_get_errstatus() /= 0) return @@ -127,7 +128,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) call psb_info(ictxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np - + iictxt = ictxt n = m !... check m and n parameters.... if (m < 1) then @@ -197,7 +198,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) allocate(psb_repl_map :: desc%indxmap, stat=info) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(iictxt,m,info) class default ! This cannot happen info = psb_err_internal_error_ @@ -208,8 +209,6 @@ subroutine psb_cdrep(m, ictxt, desc, info) tovr = -1 call psi_bld_tmpovrl(tovr,desc,info) -!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index 773b71d5..94510cec 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -29,9 +29,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: psb_cdbldext.f90 +! File: psb_dcdbldext.f90 ! -! Subroutine: psb_cdbldext +! Subroutine: psb_dcdbldext ! This routine takes a matrix A with its descriptor, and builds the ! auxiliary descriptor corresponding to the number of overlap levels ! specified on input. @@ -73,22 +73,22 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) #endif ! .. Array Arguments .. - integer(psb_ipk_), intent(in) :: novr - Type(psb_dspmat_type), Intent(in) :: a + integer(psb_ipk_), intent(in) :: novr + Type(psb_dspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in),optional :: extype ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& + integer(psb_ipk_) :: i, j, err_act,m,& + & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_ipk_) :: icomm, err_act + integer(psb_mpik_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -96,7 +96,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & t_halo_out(:),temp(:),maskr(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err name='psb_dcdbldext' info = psb_success_ @@ -130,17 +131,17 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (novr<0) then info=psb_err_iarg_neg_ - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) + ierr(1)=1; ierr(2)=novr + call psb_errpush(info,name,i_err=ierr) goto 9999 endif select case(extype_) case(psb_ovt_xhal_,psb_ovt_asov_) case default + ierr(1)=5; ierr(2)=extype_ call psb_errpush(psb_err_input_value_invalid_i_,& - & name,i_err=(/5,extype_,0,0,0/)) + & name,i_err=ierr) goto 9999 end select @@ -259,8 +260,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) - + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -361,7 +361,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -373,8 +373,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+2) = gidx tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 - call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) - + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -406,7 +405,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -468,14 +467,12 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - - if (info /= psb_success_) then + call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') goto 9999 end if - idxs = 0 idxr = 0 counter = 1 @@ -505,9 +502,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,& + & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') goto 9999 @@ -517,7 +514,6 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr call psb_ensure_size(iszr,maskr,info) - if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -566,7 +562,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! proc_id = temp(i) - call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) + call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -627,7 +623,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) - call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -654,7 +650,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call desc_ov%indxmap%set_lr(n_col_prev) - call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -672,7 +668,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) + ierr(1)=5; ierr(2)=extype_ + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select @@ -698,10 +695,12 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if ((info == psb_success_).and.allocated(icol)) & + & deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='deallocate',i_err=(/info,0,0,0,0/)) + ierr(1) = info + call psb_errpush(psb_err_from_subroutine_ai_,name, & + & a_err='deallocate',i_err=ierr) goto 9999 end if end if diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index 419f8666..92012a91 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -29,9 +29,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: psb_cdbldext.f90 +! File: psb_scdbldext.f90 ! -! Subroutine: psb_cdbldext +! Subroutine: psb_scdbldext ! This routine takes a matrix A with its descriptor, and builds the ! auxiliary descriptor corresponding to the number of overlap levels ! specified on input. @@ -73,7 +73,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) #endif ! .. Array Arguments .. - integer(psb_ipk_), intent(in) :: novr + integer(psb_ipk_), intent(in) :: novr Type(psb_sspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov @@ -81,14 +81,14 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_), intent(in),optional :: extype ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& + integer(psb_ipk_) :: i, j, err_act,m,& + & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_ipk_) :: icomm, err_act + integer(psb_mpik_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -96,14 +96,21 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & t_halo_out(:),temp(:),maskr(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err name='psb_scdbldext' info = psb_success_ + if (psb_errstatus_fatal()) return 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() icomm = desc_a%get_mpic() Call psb_info(ictxt, me, np) @@ -124,17 +131,17 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (novr<0) then info=psb_err_iarg_neg_ - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) + ierr(1)=1; ierr(2)=novr + call psb_errpush(info,name,i_err=ierr) goto 9999 endif select case(extype_) case(psb_ovt_xhal_,psb_ovt_asov_) case default + ierr(1)=5; ierr(2)=extype_ call psb_errpush(psb_err_input_value_invalid_i_,& - & name,i_err=(/5,extype_,0,0,0/)) + & name,i_err=ierr) goto 9999 end select @@ -143,10 +150,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= psb_success_) then + + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_cdcpy') goto 9999 end if @@ -219,15 +226,12 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& + if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),& + & tmp_ovr_idx(l_tmp_ovr_idx), & & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) + if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -256,7 +260,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -357,7 +361,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -369,7 +373,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+2) = gidx tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 - call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -401,7 +405,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -463,11 +467,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoall') goto 9999 end if idxs = 0 @@ -490,21 +493,20 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,& + & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoallv') goto 9999 end if @@ -560,7 +562,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! proc_id = temp(i) - call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) + call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -621,7 +623,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) - call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -648,7 +650,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call desc_ov%indxmap%set_lr(n_col_prev) - call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -666,7 +668,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) + ierr(1)=5; ierr(2)=extype_ + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select @@ -692,10 +695,12 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if ((info == psb_success_).and.allocated(icol)) & + & deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='deallocate',i_err=(/info,0,0,0,0/)) + ierr(1) = info + call psb_errpush(psb_err_from_subroutine_ai_,name, & + & a_err='deallocate',i_err=ierr) goto 9999 end if end if diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index 7c3be51f..b2bbd3da 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -73,23 +73,22 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) #endif ! .. Array Arguments .. - integer(psb_ipk_), intent(in) :: novr + integer(psb_ipk_), intent(in) :: novr Type(psb_zspmat_type), Intent(in) :: a Type(psb_desc_type), Intent(in), target :: desc_a Type(psb_desc_type), Intent(out) :: desc_ov integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in),optional :: extype - ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me,m,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& + integer(psb_ipk_) :: i, j, err_act,m,& + & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_ipk_) :: icomm, err_act + integer(psb_mpik_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -97,14 +96,21 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & t_halo_out(:),temp(:),maskr(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err name='psb_zcdbldext' info = psb_success_ + if (psb_errstatus_fatal()) return 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() icomm = desc_a%get_mpic() Call psb_info(ictxt, me, np) @@ -125,17 +131,17 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (novr<0) then info=psb_err_iarg_neg_ - int_err(1)=1 - int_err(2)=novr - call psb_errpush(info,name,i_err=int_err) + ierr(1)=1; ierr(2)=novr + call psb_errpush(info,name,i_err=ierr) goto 9999 endif select case(extype_) case(psb_ovt_xhal_,psb_ovt_asov_) case default + ierr(1)=5; ierr(2)=extype_ call psb_errpush(psb_err_input_value_invalid_i_,& - & name,i_err=(/5,extype_,0,0,0/)) + & name,i_err=ierr) goto 9999 end select @@ -144,10 +150,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= psb_success_) then + + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='psb_cdcpy') goto 9999 end if @@ -220,15 +226,12 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& + if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),& + & tmp_ovr_idx(l_tmp_ovr_idx), & & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) + if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -257,7 +260,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -358,7 +361,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -370,7 +373,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+2) = gidx tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 - call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -402,7 +405,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 endif - call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -464,11 +467,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoall' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoall') goto 9999 end if idxs = 0 @@ -491,21 +493,20 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& - & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= psb_success_) then + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,& + & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo) + if (minfo /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mpi_alltoallv' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(info,name,a_err='mpi_alltoallv') goto 9999 end if @@ -561,7 +562,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! proc_id = temp(i) - call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) + call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -622,7 +623,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) - call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -649,7 +650,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call desc_ov%indxmap%set_lr(n_col_prev) - call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-ione) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 @@ -667,7 +668,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) + ierr(1)=5; ierr(2)=extype_ + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select @@ -693,10 +695,12 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if ((info == psb_success_).and.allocated(icol)) & + & deallocate(icol,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='deallocate',i_err=(/info,0,0,0,0/)) + ierr(1) = info + call psb_errpush(psb_err_from_subroutine_ai_,name, & + & a_err='deallocate',i_err=ierr) goto 9999 end if end if