fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3-integer8:

Browse Source 
base/modules/parts.fh
 base/modules/psb_const_mod.F90
 base/modules/psi_bcast_mod.F90
 base/tools/psb_ccdbldext.F90
 base/tools/psb_cd_inloc.f90
 base/tools/psb_cdall.f90
 base/tools/psb_cdals.f90
 base/tools/psb_cdalv.f90
 base/tools/psb_cdrep.f90
 base/tools/psb_dcdbldext.F90
 base/tools/psb_scdbldext.F90
 base/tools/psb_zcdbldext.F90

Added broadcasts with handling of ICTXT. 
Advance in tools.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent f059962c4c
commit d2fb497ead
12 changed files with 654 additions and 245 deletions
Show Stats Download Patch File Download Diff File

5
base/modules/parts.fh
Unescape Escape View File

@ -1,7 +1,8 @@
interface interface
!.....user passed subroutine..... !.....user passed subroutine.....
subroutine parts(glob_index,nrow,np,pv,nv) subroutine parts(glob_index,nrow,np,pv,nv)
integer, intent (in) :: glob_index,np,nrow import :: psb_ipk_
integer, intent (out) :: nv, pv(*) integer(psb_ipk_), intent (in) :: glob_index,np,nrow
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine parts end subroutine parts
end interface end interface

3
base/modules/psb_const_mod.F90
Unescape Escape View File

@ -68,7 +68,8 @@ module psb_const_mod
! Handy & miscellaneous constants ! Handy & miscellaneous constants
! !
integer(psb_ipk_), parameter :: izero=0, ione=1 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 :: 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_spk_), parameter :: szero=0.e0, sone=1.e0
real(psb_dpk_), parameter :: dzero=0.d0, done=1.d0 real(psb_dpk_), parameter :: dzero=0.d0, done=1.d0
complex(psb_spk_), parameter :: czero=(0.e0,0.0e0) complex(psb_spk_), parameter :: czero=(0.e0,0.0e0)

437
base/modules/psi_bcast_mod.F90
Unescape Escape View File

@ -9,8 +9,25 @@ module psi_bcast_mod
& psb_zbcasts, psb_zbcastv, psb_zbcastm,& & psb_zbcasts, psb_zbcastv, psb_zbcastm,&
& psb_sbcasts, psb_sbcastv, psb_sbcastm,& & psb_sbcasts, psb_sbcastv, psb_sbcastm,&
& psb_cbcasts, psb_cbcastv, psb_cbcastm,& & psb_cbcasts, psb_cbcastv, psb_cbcastm,&
& psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv & psb_hbcasts, psb_hbcastv,&
end interface & 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 contains
@ -535,4 +552,420 @@ contains
end subroutine psb_lbcastv 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 end module psi_bcast_mod

84
base/tools/psb_ccdbldext.F90
Unescape Escape View File

@ -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(out) :: info
integer(psb_ipk_), intent(in),optional :: extype integer(psb_ipk_), intent(in),optional :: extype
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: i, j, np, me,m,& integer(psb_ipk_) :: i, j, err_act,m,&
& ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, &
& index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo & 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,& 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,& & n_elem_send,tot_recv,tot_elem,cntov_o,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, & & counter_t,n_elem,i_ovr,jj,proc_id,isz, &
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ & 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 :: irow(:), icol(:)
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) 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(:) & t_halo_out(:),temp(:),maskr(:)
integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_ccdbldext' name='psb_ccdbldext'
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() 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() ictxt = desc_a%get_context()
icomm = desc_a%get_mpic() icomm = desc_a%get_mpic()
Call psb_info(ictxt, me, np) 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 if (novr<0) then
info=psb_err_iarg_neg_ info=psb_err_iarg_neg_
int_err(1)=1 ierr(1)=1; ierr(2)=novr
int_err(2)=novr call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
select case(extype_) select case(extype_)
case(psb_ovt_xhal_,psb_ovt_asov_) case(psb_ovt_xhal_,psb_ovt_asov_)
case default case default
ierr(1)=5; ierr(2)=extype_
call psb_errpush(psb_err_input_value_invalid_i_,& call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/5,extype_,0,0,0/)) & name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -144,10 +150,10 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
& ': Calling desccpy' & ': Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info /= psb_success_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_cdcpy' call psb_errpush(info,name,a_err='psb_cdcpy')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if 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),& Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),&
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info) & t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
if (info /= psb_success_) then if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') & tmp_ovr_idx(l_tmp_ovr_idx), &
goto 9999
end if
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) & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
if (info /= psb_success_) then 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 goto 9999
end if end if
halo(:) = desc_a%halo_index(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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+2) = gidx
tmp_ovr_idx(counter_o+3) = -1 tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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 ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' call psb_errpush(info,name,a_err='mpi_alltoall')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
idxs = 0 idxs = 0
@ -491,21 +493,20 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
iszr=sum(rvsz) iszr=sum(rvsz)
if (max(iszr,1) > lworkr) then if (max(iszr,1) > lworkr) then
call psb_realloc(max(iszr,1),workr,info) call psb_realloc(max(iszr,1),workr,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_ if (psb_errstatus_fatal()) then
ch_err='psb_realloc' info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
lworkr = max(iszr,1) lworkr = max(iszr,1)
end if end if
call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,&
& workr,rvsz,brvindx,psb_mpi_integer,icomm,info) & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err='mpi_alltoallv')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -561,7 +562,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
! !
proc_id = temp(i) 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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. ! 5. n_col(ov) current.
! !
call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 goto 9999
@ -649,7 +650,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
! 5. n_col(ov) current. ! 5. n_col(ov) current.
! !
call desc_ov%indxmap%set_lr(n_col_prev) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 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(tmp_halo,desc_ov%ext_index,info)
call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info)
case default 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 goto 9999
end select end select
@ -693,10 +695,12 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
if (info == psb_success_) then if (info == psb_success_) then
if (allocated(irow)) deallocate(irow,stat=info) 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 if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name, & call psb_errpush(psb_err_from_subroutine_ai_,name, &
& a_err='deallocate',i_err=(/info,0,0,0,0/)) & a_err='deallocate',i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if

34
base/tools/psb_cd_inloc.f90
Unescape Escape View File

@ -63,6 +63,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
integer(psb_ipk_), allocatable :: temp_ovrlap(:), tmpgidx(:,:), vl(:),& integer(psb_ipk_), allocatable :: temp_ovrlap(:), tmpgidx(:,:), vl(:),&
& nov(:), ov_idx(:,:) & nov(:), ov_idx(:,:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
logical :: check_, islarge logical :: check_, islarge
character(len=20) :: name character(len=20) :: name
@ -77,7 +78,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': start',np & write(debug_unit,*) me,' ',trim(name),': start',np
iictxt = ictxt
loc_row = size(v) loc_row = size(v)
if (.false.) then if (.false.) then
@ -325,7 +326,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
if (ov_idx(j,1) == i) exit if (ov_idx(j,1) == i) exit
j = j + 1 j = j + 1
end do 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) select type(aa => desc%indxmap)
type is (psb_repl_map) type is (psb_repl_map)
call aa%repl_map_init(ictxt,m,info) call aa%repl_map_init(iictxt,m,info)
class default class default
call aa%init(ictxt,vl(1:nlu),info) call aa%init(iictxt,vl(1:nlu),info)
end select end select
call psi_bld_tmpovrl(temp_ovrlap,desc,info) call psi_bld_tmpovrl(temp_ovrlap,desc,info)
@ -371,31 +372,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
goto 9999 goto 9999
endif 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) call psb_erractionrestore(err_act)
return return

7
base/tools/psb_cdall.f90
Unescape Escape View File

@ -49,6 +49,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: err_act, n_, flag_, i, me, np, nlp, nnv, lr integer(psb_ipk_) :: err_act, n_, flag_, i, me, np, nlp, nnv, lr
integer(psb_ipk_), allocatable :: itmpsz(:) integer(psb_ipk_), allocatable :: itmpsz(:)
integer(psb_mpik_) :: iictxt
@ -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_erractionsave(err_act)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
iictxt = ictxt
if (count((/ present(vg),present(vl),& if (count((/ present(vg),present(vl),&
& present(parts),present(nl), present(repl) /)) /= 1) then & present(parts),present(nl), present(repl) /)) /= 1) then
info=psb_err_no_optional_arg_ 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 if (info == psb_success_) then
select type(aa => desc%indxmap) select type(aa => desc%indxmap)
type is (psb_repl_map) 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) 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 class default
! This cannot happen ! This cannot happen
info = psb_err_internal_error_ info = psb_err_internal_error_

33
base/tools/psb_cdals.f90
Unescape Escape View File

@ -62,6 +62,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
integer(psb_ipk_) :: int_err(5),exch(3) integer(psb_ipk_) :: int_err(5),exch(3)
integer(psb_ipk_), allocatable :: prc_v(:), temp_ovrlap(:), loc_idx(:) integer(psb_ipk_), allocatable :: prc_v(:), temp_ovrlap(:), loc_idx(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
character(len=20) :: name character(len=20) :: name
if(psb_get_errstatus() /= 0) return 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) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': ',np & write(debug_unit,*) me,' ',trim(name),': ',np
iictxt = ictxt
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
!... check m and n parameters.... !... check m and n parameters....
if (m < 1) then if (m < 1) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
err=info err=info
int_err(1) = 1 int_err(1) = 1; int_err(2) = m;
int_err(2) = m
call psb_errpush(err,name,int_err) call psb_errpush(err,name,int_err)
goto 9999 goto 9999
else if (n < 1) then else if (n < 1) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
err=info err=info
int_err(1) = 2 int_err(1) = 2 ; int_err(2) = n;
int_err(2) = n
call psb_errpush(err,name,int_err) call psb_errpush(err,name,int_err)
goto 9999 goto 9999
endif endif
@ -100,9 +100,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
& write(debug_unit,*) me,' ',trim(name),': doing global checks' & write(debug_unit,*) me,' ',trim(name),': doing global checks'
!global check on m and n parameters !global check on m and n parameters
if (me == psb_root_) then if (me == psb_root_) then
exch(1)=m exch(1)=m; exch(2)=n; exch(3)=psb_cd_get_large_threshold()
exch(2)=n
exch(3)=psb_cd_get_large_threshold()
call psb_bcast(ictxt,exch(1:3),root=psb_root_) call psb_bcast(ictxt,exch(1:3),root=psb_root_)
else else
call psb_bcast(ictxt,exch(1:3),root=psb_root_) 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 ! count local rows number
loc_row = max(1,(m+np-1)/np) loc_row = max(1,(m+np-1)/np)
! allocate work vector ! 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) allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -229,7 +224,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
if (prc_v(j) == me) then if (prc_v(j) == me) then
! this point belongs to me ! this point belongs to me
k = k + 1 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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 loc_idx(k) = i
if (nprocs > 1) then 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) select type(aa => desc%indxmap)
type is (psb_repl_map) type is (psb_repl_map)
call aa%repl_map_init(ictxt,m,info) call aa%repl_map_init(iictxt,m,info)
class default class default
call aa%init(ictxt,loc_idx(1:k),info) call aa%init(iictxt,loc_idx(1:k),info)
end select end select
@ -289,16 +284,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
Goto 9999 Goto 9999
endif 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_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end' & write(debug_unit,*) me,' ',trim(name),': end'

9
base/tools/psb_cdalv.f90
Unescape Escape View File

@ -63,6 +63,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
integer(psb_ipk_) :: int_err(5),exch(3) integer(psb_ipk_) :: int_err(5),exch(3)
integer(psb_ipk_), allocatable :: temp_ovrlap(:) integer(psb_ipk_), allocatable :: temp_ovrlap(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
character(len=20) :: name character(len=20) :: name
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
@ -75,7 +76,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': ',np,me & write(debug_unit,*) me,' ',trim(name),': ',np,me
iictxt = ictxt
m = size(v) m = size(v)
n = m n = m
!... check m and n parameters.... !... check m and n parameters....
@ -189,11 +190,11 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
select type(aa => desc%indxmap) select type(aa => desc%indxmap)
type is (psb_repl_map) 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) 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) type is (psb_glist_map)
call aa%glist_map_init(ictxt,v,info) call aa%glist_map_init(iictxt,v,info)
class default class default
! This cannot happen ! This cannot happen
info = psb_err_internal_error_ info = psb_err_internal_error_

7
base/tools/psb_cdrep.f90
Unescape Escape View File

@ -115,6 +115,7 @@ subroutine psb_cdrep(m, ictxt, desc, info)
integer(psb_ipk_) :: i,np,me,err,n,err_act 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_) :: int_err(5),exch(2), thalo(1), tovr(1), text(1)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
character(len=20) :: name character(len=20) :: name
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
@ -127,7 +128,7 @@ subroutine psb_cdrep(m, ictxt, desc, info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': ',np & write(debug_unit,*) me,' ',trim(name),': ',np
iictxt = ictxt
n = m n = m
!... check m and n parameters.... !... check m and n parameters....
if (m < 1) then if (m < 1) then
@ -197,7 +198,7 @@ subroutine psb_cdrep(m, ictxt, desc, info)
allocate(psb_repl_map :: desc%indxmap, stat=info) allocate(psb_repl_map :: desc%indxmap, stat=info)
select type(aa => desc%indxmap) select type(aa => desc%indxmap)
type is (psb_repl_map) type is (psb_repl_map)
call aa%repl_map_init(ictxt,m,info) call aa%repl_map_init(iictxt,m,info)
class default class default
! This cannot happen ! This cannot happen
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -208,8 +209,6 @@ subroutine psb_cdrep(m, ictxt, desc, info)
tovr = -1 tovr = -1
call psi_bld_tmpovrl(tovr,desc,info) call psi_bld_tmpovrl(tovr,desc,info)
!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end' & write(debug_unit,*) me,' ',trim(name),': end'

57
base/tools/psb_dcdbldext.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! This routine takes a matrix A with its descriptor, and builds the
! auxiliary descriptor corresponding to the number of overlap levels ! auxiliary descriptor corresponding to the number of overlap levels
! specified on input. ! specified on input.
@ -81,14 +81,14 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
integer(psb_ipk_), intent(in),optional :: extype integer(psb_ipk_), intent(in),optional :: extype
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: i, j, np, me,m,& integer(psb_ipk_) :: i, j, err_act,m,&
& ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, &
& index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo & 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,& 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,& & n_elem_send,tot_recv,tot_elem,cntov_o,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, & & counter_t,n_elem,i_ovr,jj,proc_id,isz, &
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ & 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 :: irow(:), icol(:)
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
@ -96,6 +96,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
& t_halo_out(:),temp(:),maskr(:) & t_halo_out(:),temp(:),maskr(:)
integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dcdbldext' name='psb_dcdbldext'
@ -130,17 +131,17 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
if (novr<0) then if (novr<0) then
info=psb_err_iarg_neg_ info=psb_err_iarg_neg_
int_err(1)=1 ierr(1)=1; ierr(2)=novr
int_err(2)=novr call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
select case(extype_) select case(extype_)
case(psb_ovt_xhal_,psb_ovt_asov_) case(psb_ovt_xhal_,psb_ovt_asov_)
case default case default
ierr(1)=5; ierr(2)=extype_
call psb_errpush(psb_err_input_value_invalid_i_,& call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/5,extype_,0,0,0/)) & name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -259,8 +260,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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+2) = gidx
tmp_ovr_idx(counter_o+3) = -1 tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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 ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo)
if (minfo /= psb_success_) then
if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall') call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999 goto 9999
end if end if
idxs = 0 idxs = 0
idxr = 0 idxr = 0
counter = 1 counter = 1
@ -505,9 +502,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
lworkr = max(iszr,1) lworkr = max(iszr,1)
end if end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,&
& workr,rvsz,brvindx,mpi_integer,icomm,info) & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoallv') call psb_errpush(info,name,a_err='mpi_alltoallv')
goto 9999 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 & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr
call psb_ensure_size(iszr,maskr,info) call psb_ensure_size(iszr,maskr,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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. ! 5. n_col(ov) current.
! !
call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 goto 9999
@ -654,7 +650,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
! 5. n_col(ov) current. ! 5. n_col(ov) current.
! !
call desc_ov%indxmap%set_lr(n_col_prev) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 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(tmp_halo,desc_ov%ext_index,info)
call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info)
case default 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 goto 9999
end select end select
@ -698,10 +695,12 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
if (info == psb_success_) then if (info == psb_success_) then
if (allocated(irow)) deallocate(irow,stat=info) 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 if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name, & call psb_errpush(psb_err_from_subroutine_ai_,name, &
& a_err='deallocate',i_err=(/info,0,0,0,0/)) & a_err='deallocate',i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if

89
base/tools/psb_scdbldext.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! This routine takes a matrix A with its descriptor, and builds the
! auxiliary descriptor corresponding to the number of overlap levels ! auxiliary descriptor corresponding to the number of overlap levels
! specified on input. ! specified on input.
@ -81,14 +81,14 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
integer(psb_ipk_), intent(in),optional :: extype integer(psb_ipk_), intent(in),optional :: extype
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: i, j, np, me,m,& integer(psb_ipk_) :: i, j, err_act,m,&
& ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, &
& index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo & 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,& 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,& & n_elem_send,tot_recv,tot_elem,cntov_o,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, & & counter_t,n_elem,i_ovr,jj,proc_id,isz, &
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ & 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 :: irow(:), icol(:)
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) 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(:) & t_halo_out(:),temp(:),maskr(:)
integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scdbldext' name='psb_scdbldext'
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() 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() ictxt = desc_a%get_context()
icomm = desc_a%get_mpic() icomm = desc_a%get_mpic()
Call psb_info(ictxt, me, np) 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 if (novr<0) then
info=psb_err_iarg_neg_ info=psb_err_iarg_neg_
int_err(1)=1 ierr(1)=1; ierr(2)=novr
int_err(2)=novr call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
select case(extype_) select case(extype_)
case(psb_ovt_xhal_,psb_ovt_asov_) case(psb_ovt_xhal_,psb_ovt_asov_)
case default case default
ierr(1)=5; ierr(2)=extype_
call psb_errpush(psb_err_input_value_invalid_i_,& call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/5,extype_,0,0,0/)) & name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -143,10 +150,10 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
& ': Calling desccpy' & ': Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info /= psb_success_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_cdcpy' call psb_errpush(info,name,a_err='psb_cdcpy')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if 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),& Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),&
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info) & t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
if (info /= psb_success_) then if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') & tmp_ovr_idx(l_tmp_ovr_idx), &
goto 9999
end if
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) & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
if (info /= psb_success_) then 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 goto 9999
end if end if
halo(:) = desc_a%halo_index(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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+2) = gidx
tmp_ovr_idx(counter_o+3) = -1 tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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 ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' call psb_errpush(info,name,a_err='mpi_alltoall')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
idxs = 0 idxs = 0
@ -490,21 +493,20 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
iszr=sum(rvsz) iszr=sum(rvsz)
if (max(iszr,1) > lworkr) then if (max(iszr,1) > lworkr) then
call psb_realloc(max(iszr,1),workr,info) call psb_realloc(max(iszr,1),workr,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_ if (psb_errstatus_fatal()) then
ch_err='psb_realloc' info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
lworkr = max(iszr,1) lworkr = max(iszr,1)
end if end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,&
& workr,rvsz,brvindx,mpi_integer,icomm,info) & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err='mpi_alltoallv')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -560,7 +562,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! !
proc_id = temp(i) 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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. ! 5. n_col(ov) current.
! !
call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 goto 9999
@ -648,7 +650,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! 5. n_col(ov) current. ! 5. n_col(ov) current.
! !
call desc_ov%indxmap%set_lr(n_col_prev) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 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(tmp_halo,desc_ov%ext_index,info)
call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info)
case default 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 goto 9999
end select end select
@ -692,10 +695,12 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
if (info == psb_success_) then if (info == psb_success_) then
if (allocated(irow)) deallocate(irow,stat=info) 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 if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name, & call psb_errpush(psb_err_from_subroutine_ai_,name, &
& a_err='deallocate',i_err=(/info,0,0,0,0/)) & a_err='deallocate',i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if

86
base/tools/psb_zcdbldext.F90
Unescape Escape View File

@ -80,16 +80,15 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in),optional :: extype integer(psb_ipk_), intent(in),optional :: extype
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: i, j, np, me,m,& integer(psb_ipk_) :: i, j, err_act,m,&
& ictxt, lovr, lworks,lworkr, n_row,n_col, n_col_prev, int_err(5),& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, &
& index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo & 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,& 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,& & n_elem_send,tot_recv,tot_elem,cntov_o,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, & & counter_t,n_elem,i_ovr,jj,proc_id,isz, &
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ & 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 :: irow(:), icol(:)
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) 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(:) & t_halo_out(:),temp(:),maskr(:)
integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_zcdbldext' name='psb_zcdbldext'
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() 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() ictxt = desc_a%get_context()
icomm = desc_a%get_mpic() icomm = desc_a%get_mpic()
Call psb_info(ictxt, me, np) 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 if (novr<0) then
info=psb_err_iarg_neg_ info=psb_err_iarg_neg_
int_err(1)=1 ierr(1)=1; ierr(2)=novr
int_err(2)=novr call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
select case(extype_) select case(extype_)
case(psb_ovt_xhal_,psb_ovt_asov_) case(psb_ovt_xhal_,psb_ovt_asov_)
case default case default
ierr(1)=5; ierr(2)=extype_
call psb_errpush(psb_err_input_value_invalid_i_,& call psb_errpush(psb_err_input_value_invalid_i_,&
& name,i_err=(/5,extype_,0,0,0/)) & name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -144,10 +150,10 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
& ': Calling desccpy' & ': Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info /= psb_success_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_cdcpy' call psb_errpush(info,name,a_err='psb_cdcpy')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if 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),& Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),&
& t_halo_out(l_tmp_halo), temp(lworkr),stat=info) & t_halo_out(l_tmp_halo), temp(lworkr),stat=info)
if (info /= psb_success_) then if (info == psb_success_) allocate(orig_ovr(l_tmp_ovr_idx),&
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') & tmp_ovr_idx(l_tmp_ovr_idx), &
goto 9999
end if
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) & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
if (info /= psb_success_) then 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 goto 9999
end if end if
halo(:) = desc_a%halo_index(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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+2) = gidx
tmp_ovr_idx(counter_o+3) = -1 tmp_ovr_idx(counter_o+3) = -1
counter_o=counter_o+3 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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 ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,psb_mpi_integer,rvsz,1,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' call psb_errpush(info,name,a_err='mpi_alltoall')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
idxs = 0 idxs = 0
@ -491,21 +493,20 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
iszr=sum(rvsz) iszr=sum(rvsz)
if (max(iszr,1) > lworkr) then if (max(iszr,1) > lworkr) then
call psb_realloc(max(iszr,1),workr,info) call psb_realloc(max(iszr,1),workr,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_ if (psb_errstatus_fatal()) then
ch_err='psb_realloc' info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
lworkr = max(iszr,1) lworkr = max(iszr,1)
end if end if
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_integer,&
& workr,rvsz,brvindx,mpi_integer,icomm,info) & workr,rvsz,brvindx,psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err='mpi_alltoallv')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -561,7 +562,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
! !
proc_id = temp(i) 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 if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') 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. ! 5. n_col(ov) current.
! !
call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 goto 9999
@ -649,7 +650,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
! 5. n_col(ov) current. ! 5. n_col(ov) current.
! !
call desc_ov%indxmap%set_lr(n_col_prev) 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 if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size')
goto 9999 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(tmp_halo,desc_ov%ext_index,info)
call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info)
case default 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 goto 9999
end select end select
@ -693,10 +695,12 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
if (info == psb_success_) then if (info == psb_success_) then
if (allocated(irow)) deallocate(irow,stat=info) 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 if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name, & call psb_errpush(psb_err_from_subroutine_ai_,name, &
& a_err='deallocate',i_err=(/info,0,0,0,0/)) & a_err='deallocate',i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if

Write Preview
Loading…
Cancel
Save