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
!.....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

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

@ -68,7 +68,8 @@ module psb_const_mod
! 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 :: 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)

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_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

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(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
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
ierr(1) = info
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
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(:),&
& nov(:), ov_idx(:,:)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
logical :: check_, islarge
character(len=20) :: name
@ -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

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
integer(psb_ipk_) :: err_act, n_, flag_, i, me, np, nlp, nnv, lr
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_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_

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_), 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'

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_), allocatable :: temp_ovrlap(:)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_mpik_) :: iictxt
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@ -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_

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_) :: 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'

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

@ -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.
@ -81,14 +81,14 @@ Subroutine psb_dcdbldext(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,6 +96,7 @@ 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
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psb_dcdbldext'
@ -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
ierr(1) = info
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
end if
end if

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

@ -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.
@ -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
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
ierr(1) = info
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
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(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
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
ierr(1) = info
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
end if
end if

Write Preview
Loading…
Cancel
Save