psblas-3.0-maint:

README
 base/comm/psb_ihalo.f90
 base/comm/psb_iovrl.f90
 base/internals/psi_bld_tmphalo.f90
 base/internals/psi_idx_cnv.f90
 base/internals/psi_idx_ins_cnv.f90
 base/internals/psi_ovrl_restr.f90
 base/internals/psi_ovrl_save.f90
 base/internals/psi_ovrl_upd.f90
 base/modules/Makefile
 base/modules/psb_base_tools_mod.f90
 base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_c_vect_mod.F90
 base/modules/psb_c_vect_mod.f90
 base/modules/psb_cd_tools_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_linmap_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_d_vect_mod.f90
 base/modules/psb_gen_block_map_mod.f90
 base/modules/psb_hash_map_mod.f90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_i_tools_mod.f90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_i_vect_mod.f90
 base/modules/psb_indx_map_mod.f90
 base/modules/psb_list_map_mod.f90
 base/modules/psb_repl_map_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_s_vect_mod.F90
 base/modules/psb_s_vect_mod.f90
 base/modules/psb_tools_mod.f90
 base/modules/psb_z_base_vect_mod.f90
 base/modules/psb_z_vect_mod.F90
 base/modules/psb_z_vect_mod.f90
 base/modules/psi_i_mod.f90
 base/serial/impl/psb_c_base_mat_impl.F90
 base/serial/impl/psb_c_base_mat_impl.f90
 base/serial/impl/psb_d_base_mat_impl.F90
 base/serial/impl/psb_d_base_mat_impl.f90
 base/serial/impl/psb_s_base_mat_impl.F90
 base/serial/impl/psb_s_base_mat_impl.f90
 base/serial/impl/psb_z_base_mat_impl.F90
 base/serial/impl/psb_z_base_mat_impl.f90
 base/tools/psb_cd_switch_ovl_indxmap.f90
 base/tools/psb_cdall.f90
 base/tools/psb_ialloc.f90
 base/tools/psb_iasb.f90
 base/tools/psb_ifree.f90
 base/tools/psb_iins.f90
 base/tools/psb_loc_to_glob.f90
 config/pac.m4
 configure.ac
 configure

Merged latest fixes from trunk.
psblas-3.0-maint
Salvatore Filippone 14 years ago
commit 383c81d2dc

@ -121,7 +121,6 @@ COMPILER NOTES.
This code is confirmed to work with the following compilers (or
later versions thereof):
NAGware 5.2;
XLF 13.1;
GNU 4.6.1;
Cray CCE 8.0.1;
@ -129,19 +128,23 @@ They are all recognized by the configure script.
To make the script work with the Cray CCE environment, it is
recommended to use the following:
./configure FC=ftn F77=ftn CC=cc
./configure FC=ftn F77=ftn CC=cc MPF90=ftn MPF77=ftn MPCC=cc
with both CCE and GNU lower-level compilers.
KNOWN ISSUES.
XLF 13.1 configures correctly, but then fails with ICEs (Internal
Compiler Error) at build time. We do not yet know whether XLF 14
compiles correctly.
For the GNU compilers 4.6.x we are aware of a number of memory management
issues that might surface in your applications; all of them (that
we're aware of) are solved in version 4.7.0.
The Intel compiler up to version 12.1 fails due to a bug in the
handling of generic interfaces.
The Intel compiler up to version 12.1 fails to compile, as of the last
version we got access to.
KNOWN ISSUES.
An annoying problem exists with some versions of MPI: if the configure
script sets -DMPI_MOD the MPI call interfaces will be resolved by

@ -427,3 +427,153 @@ end subroutine psb_ihalov
subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ihalo_vect
use psi_mod
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_ihalov'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
ijx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
if (present(tran)) then
tran_ = psb_toupper(tran)
else
tran_ = 'N'
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
endif
if (present(mode)) then
imode = mode
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
err=info
call psb_errcomm(ictxt,err)
if(err /= 0) goto 9999
if(present(alpha)) then
if(alpha /= done) then
call x%scal(alpha)
end if
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,izero,x%v,&
& desc_a,iwork,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,ione,x%v,&
& desc_a,iwork,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if (info /= psb_success_) then
ch_err='PSI_swapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_ihalo_vect

@ -388,3 +388,133 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
end if
return
end subroutine psb_iovrlv
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrl_vect
use psi_mod
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_iovrlv'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
ijx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
k = 1
if (present(update)) then
update_ = update
else
update_ = psb_avg_
endif
if (present(mode)) then
mode_ = mode
else
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif
do_swap = (mode_ /= 0)
! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
err=info
call psb_errcomm(ictxt,err)
if(err /= 0) goto 9999
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,ione,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_iovrl_vect

@ -100,7 +100,7 @@ subroutine psi_bld_tmphalo(desc,info)
helem(i) = n_row+i ! desc%loc_to_glob(n_row+i)
end do
call desc%indxmap%l2g(helem(1:nh),info)
call desc%indxmap%l2gip(helem(1:nh),info)
call desc%indxmap%fnd_owner(helem(1:nh),hproc,info)
if (info /= psb_success_) then

@ -112,7 +112,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
end if
endif
call desc%indxmap%g2l(idxin(1:nv),info,mask=mask,owned=owned)
call desc%indxmap%g2lip(idxin(1:nv),info,mask=mask,owned=owned)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='g2l')

@ -113,7 +113,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask,lidx)
endif
call desc%indxmap%g2l_ins(idxin(1:nv),info,mask=mask,lidx=lidx)
call desc%indxmap%g2lip_ins(idxin(1:nv),info,mask=mask,lidx=lidx)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='g2l_ins')

@ -531,6 +531,51 @@ end subroutine psi_iovrl_restrr2
subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_restr_vect
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_iovrl_restrr1'
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iovrl_restr_vect
subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restr_vect
use psb_s_base_vect_mod

@ -579,6 +579,57 @@ end subroutine psi_iovrl_saver2
subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_save_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_iovrl_saver1'
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iovrl_save_vect
subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_save_vect
use psb_realloc_mod

@ -748,6 +748,90 @@ subroutine psi_iovrl_updr2(x,desc_a,update,info)
end subroutine psi_iovrl_updr2
subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_iovrl_upd_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:)
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iovrl_upd_vect
subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_upd_vect
use psb_realloc_mod

@ -6,7 +6,7 @@ UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\
psb_gen_block_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o\
psb_glist_map_mod.o psb_hash_map_mod.o \
psb_desc_type.o psb_sort_mod.o psb_serial_mod.o \
psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_cd_tools_mod.o psb_i_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \
psb_penv_mod.o $(COMMINT) psb_error_impl.o \
psb_base_linmap_mod.o psb_linmap_mod.o \
@ -109,9 +109,10 @@ psb_s_vect_mod.o: psb_s_base_vect_mod.o
psb_d_vect_mod.o: psb_d_base_vect_mod.o
psb_c_vect_mod.o: psb_c_base_vect_mod.o
psb_z_vect_mod.o: psb_z_base_vect_mod.o
psb_tools_mod.o: psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_c_tools_mod.o psb_z_tools_mod.o
psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o psb_c_tools_mod.o psb_z_tools_mod.o: psb_desc_type.o psi_mod.o psb_mat_mod.o
psb_tools_mod.o: psb_cd_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_i_tools_mod.o psb_c_tools_mod.o psb_z_tools_mod.o
psb_cd_tools_mod.o psb_i_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o psb_c_tools_mod.o psb_z_tools_mod.o: psb_desc_type.o psi_mod.o psb_mat_mod.o
psb_i_tools_mod.o: psb_i_vect_mod.o
psb_s_tools_mod.o: psb_s_vect_mod.o
psb_d_tools_mod.o: psb_d_vect_mod.o
psb_c_tools_mod.o: psb_c_vect_mod.o

@ -68,6 +68,7 @@ module psb_c_base_vect_mod
procedure, pass(x) :: bld_n => c_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => c_base_all
procedure, pass(x) :: mold => c_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
@ -219,6 +220,18 @@ contains
end subroutine c_base_all
subroutine c_base_mold(x, y, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_base_vect_type), intent(in) :: x
class(psb_c_base_vect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_c_base_vect_type :: y, stat=info)
end subroutine c_base_mold
!
! Insert a bunch of values at specified positions.
!

@ -100,7 +100,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_vect_type :: x%v,stat=info)
endif
@ -117,7 +121,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_vect_type :: x%v,stat=info)
endif
@ -411,7 +419,11 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_vect_type :: x%v,stat=info)
endif
@ -531,7 +543,11 @@ contains
complex(psb_spk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)

@ -0,0 +1,213 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psb_cd_tools_mod
use psb_const_mod
use psb_descriptor_type
use psb_gen_block_map_mod
use psb_list_map_mod
use psb_glist_map_mod
use psb_hash_map_mod
use psb_repl_map_mod
interface psb_cd_set_bld
subroutine psb_cd_set_bld(desc,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_) :: info
end subroutine psb_cd_set_bld
end interface
interface psb_cd_set_ovl_bld
subroutine psb_cd_set_ovl_bld(desc,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_) :: info
end subroutine psb_cd_set_ovl_bld
end interface
interface psb_cd_reinit
Subroutine psb_cd_reinit(desc,info)
import :: psb_ipk_, psb_desc_type
Implicit None
! .. Array Arguments ..
Type(psb_desc_type), Intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
end Subroutine psb_cd_reinit
end interface
interface psb_cdcpy
subroutine psb_cdcpy(desc_in, desc_out, info)
import :: psb_ipk_, psb_desc_type
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cdcpy
end interface
interface psb_cdprt
subroutine psb_cdprt(iout,desc_p,glob,short)
import :: psb_ipk_, psb_desc_type
implicit none
type(psb_desc_type), intent(in) :: desc_p
integer(psb_ipk_), intent(in) :: iout
logical, intent(in), optional :: glob,short
end subroutine psb_cdprt
end interface
interface psb_cdins
subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(out) :: ila(:), jla(:)
end subroutine psb_cdinsrc
subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: nz,ja(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(out) :: jla(:)
logical, optional, target, intent(in) :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
end subroutine psb_cdinsc
end interface
interface psb_cdbldext
Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
import :: psb_ipk_, psb_desc_type
Implicit None
Type(psb_desc_type), Intent(in), target :: desc_a
integer(psb_ipk_), intent(in) :: in_list(:)
Type(psb_desc_type), Intent(out) :: desc_ov
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional, target :: mask(:)
integer(psb_ipk_), intent(in),optional :: extype
end Subroutine psb_cd_lstext
end interface
interface psb_cdren
subroutine psb_cdren(trans,iperm,desc_a,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(inout) :: iperm(:)
character, intent(in) :: trans
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cdren
end interface
interface psb_get_overlap
subroutine psb_get_ovrlap(ovrel,desc,info)
import :: psb_ipk_, psb_desc_type
implicit none
integer(psb_ipk_), allocatable, intent(out) :: ovrel(:)
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
end subroutine psb_get_ovrlap
end interface
interface psb_icdasb
subroutine psb_icdasb(desc,info,ext_hv)
import :: psb_ipk_, psb_desc_type
Type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
interface psb_cdall
subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,&
& globalcheck,lidx)
import :: psb_ipk_, psb_desc_type, psb_parts
implicit None
procedure(psb_parts) :: parts
integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl,lidx(:)
integer(psb_ipk_), intent(in) :: flag
logical, intent(in) :: repl, globalcheck
integer(psb_ipk_), intent(out) :: info
type(psb_desc_type), intent(out) :: desc
optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck,lidx
end subroutine psb_cdall
end interface
interface psb_cdasb
module procedure psb_cdasb
end interface
interface psb_get_boundary
module procedure psb_get_boundary
end interface
interface
subroutine psb_cd_switch_ovl_indxmap(desc,info)
import :: psb_ipk_, psb_desc_type
implicit None
include 'parts.fh'
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cd_switch_ovl_indxmap
end interface
contains
subroutine psb_get_boundary(bndel,desc,info)
use psi_mod, only : psi_crea_bnd_elem
implicit none
integer(psb_ipk_), allocatable, intent(out) :: bndel(:)
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
call psi_crea_bnd_elem(bndel,desc,info)
end subroutine psb_get_boundary
subroutine psb_cdasb(desc,info)
Type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
call psb_icdasb(desc,info,ext_hv=.false.)
end subroutine psb_cdasb
end module psb_cd_tools_mod

@ -68,6 +68,7 @@ module psb_d_base_vect_mod
procedure, pass(x) :: bld_n => d_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => d_base_all
procedure, pass(x) :: mold => d_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
@ -219,6 +220,18 @@ contains
end subroutine d_base_all
subroutine d_base_mold(x, y, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_base_vect_type), intent(in) :: x
class(psb_d_base_vect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_d_base_vect_type :: y, stat=info)
end subroutine d_base_mold
!
! Insert a bunch of values at specified positions.
!

@ -124,19 +124,6 @@ module psb_d_linmap_mod
end function psb_d_linmap
end interface
interface psb_linmaps
subroutine psb_d_linmaps(mapout,map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr)
use psb_d_mat_mod, only : psb_dspmat_type
import :: psb_ipk_, psb_dlinmap_type, psb_desc_type
implicit none
type(psb_dlinmap_type), intent(inout) :: mapout
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(in) :: map_X2Y, map_Y2X
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:)
end subroutine psb_d_linmaps
end interface
private :: d_map_sizeof, d_is_asb, d_free

@ -100,7 +100,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_vect_type :: x%v,stat=info)
endif
@ -117,7 +121,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_vect_type :: x%v,stat=info)
endif
@ -411,7 +419,11 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_vect_type :: x%v,stat=info)
endif
@ -531,7 +543,11 @@ contains
real(psb_dpk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)

@ -144,7 +144,7 @@ contains
end if
idxv(1) = idx
call idxmap%l2g(idxv,info,owned=owned)
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine block_l2gs1
@ -159,7 +159,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2g(idxout,info,mask,owned)
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine block_l2gs2
@ -234,7 +234,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2g(idxout(1:im),info,mask,owned)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) then
info = -3
end if
@ -257,7 +257,7 @@ contains
end if
idxv(1) = idx
call idxmap%g2l(idxv,info,owned=owned)
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine block_g2ls1
@ -272,7 +272,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2l(idxout,info,mask,owned)
call idxmap%g2lip(idxout,info,mask,owned)
end subroutine block_g2ls2
@ -399,7 +399,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l(idxout(1:im),info,mask,owned)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine block_g2lv2
@ -425,9 +425,9 @@ contains
idxv(1) = idx
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2l_ins(idxv,info,lidx=lidxv)
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2l_ins(idxv,info)
call idxmap%g2lip_ins(idxv,info)
end if
idx = idxv(1)
@ -443,7 +443,7 @@ contains
integer, intent(in), optional :: lidx
idxout = idxin
call idxmap%g2l_ins(idxout,info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine block_g2ls2_ins
@ -659,7 +659,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l_ins(idxout(1:im),info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (is > im) then
!!$ write(0,*) 'g2lv2_ins err -3'
info = -3

@ -167,7 +167,7 @@ contains
end if
idxv(1) = idx
call idxmap%l2g(idxv,info,owned=owned)
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine hash_l2gs1
@ -182,7 +182,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2g(idxout,info,mask,owned)
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine hash_l2gs2
@ -255,7 +255,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2g(idxout(1:im),info,mask,owned)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) then
write(0,*) 'l2gv2 err -3'
info = -3
@ -279,7 +279,7 @@ contains
end if
idxv(1) = idx
call idxmap%g2l(idxv,info,owned=owned)
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine hash_g2ls1
@ -294,7 +294,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2l(idxout,info,mask,owned)
call idxmap%g2lip(idxout,info,mask,owned)
end subroutine hash_g2ls2
@ -429,7 +429,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l(idxout(1:im),info,mask,owned)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) then
write(0,*) 'g2lv2 err -3'
info = -3
@ -459,9 +459,9 @@ contains
idxv(1) = idx
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2l_ins(idxv,info,lidx=lidxv)
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2l_ins(idxv,info)
call idxmap%g2lip_ins(idxv,info)
end if
idx = idxv(1)
@ -478,7 +478,7 @@ contains
idxout = idxin
call idxmap%g2l_ins(idxout,info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine hash_g2ls2_ins
@ -740,7 +740,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l_ins(idxout(1:im),info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (is > im) then
write(0,*) 'g2lv2_ins err -3'
info = -3

@ -68,6 +68,7 @@ module psb_i_base_vect_mod
procedure, pass(x) :: bld_n => i_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => i_base_all
procedure, pass(x) :: mold => i_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
@ -219,6 +220,18 @@ contains
end subroutine i_base_all
subroutine i_base_mold(x, y, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_vect_type), intent(in) :: x
class(psb_i_base_vect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_i_base_vect_type :: y, stat=info)
end subroutine i_base_mold
!
! Insert a bunch of values at specified positions.
!

@ -29,9 +29,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psb_iv_tools_mod
use psb_const_mod
use psb_descriptor_type
module psb_i_tools_mod
use psb_descriptor_type, only : psb_desc_type, psb_ipk_, psb_success_
use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type
interface psb_geall
@ -49,6 +49,14 @@ module psb_iv_tools_mod
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
end subroutine psb_iallocv
subroutine psb_ialloc_vect(x, desc_a,info,n)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_i_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
end subroutine psb_ialloc_vect
end interface
@ -65,6 +73,15 @@ module psb_iv_tools_mod
integer(psb_ipk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_iasbv
subroutine psb_iasb_vect(x, desc_a, info,mold, scratch)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
end subroutine psb_iasb_vect
end interface
@ -81,10 +98,17 @@ module psb_iv_tools_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ifreev
subroutine psb_ifree_vect(x, desc_a, info)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ifree_vect
end interface
interface psb_geins
subroutine psb_iinsi(m,irw,val, x,desc_a,info,dupl)
subroutine psb_iinsi(m,irw,val, x,desc_a,info,dupl,local)
import :: psb_ipk_, psb_desc_type
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
@ -93,8 +117,9 @@ module psb_iv_tools_mod
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iinsi
subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl)
subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl,local)
import :: psb_ipk_, psb_desc_type
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
@ -103,7 +128,20 @@ module psb_iv_tools_mod
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iinsvi
subroutine psb_iins_vect(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_ipk_, &
& psb_i_base_vect_type, psb_i_vect_type
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect
end interface
@ -289,200 +327,5 @@ contains
res = (lx>0)
end subroutine psb_local_index_v
end module psb_iv_tools_mod
module psb_cd_if_tools_mod
use psb_const_mod
use psb_descriptor_type
use psb_gen_block_map_mod
use psb_list_map_mod
use psb_glist_map_mod
use psb_hash_map_mod
use psb_repl_map_mod
interface psb_cd_set_bld
subroutine psb_cd_set_bld(desc,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_) :: info
end subroutine psb_cd_set_bld
end interface
interface psb_cd_set_ovl_bld
subroutine psb_cd_set_ovl_bld(desc,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_) :: info
end subroutine psb_cd_set_ovl_bld
end interface
interface psb_cd_reinit
Subroutine psb_cd_reinit(desc,info)
import :: psb_ipk_, psb_desc_type
Implicit None
! .. Array Arguments ..
Type(psb_desc_type), Intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
end Subroutine psb_cd_reinit
end interface
interface psb_cdcpy
subroutine psb_cdcpy(desc_in, desc_out, info)
import :: psb_ipk_, psb_desc_type
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cdcpy
end interface
interface psb_cdprt
subroutine psb_cdprt(iout,desc_p,glob,short)
import :: psb_ipk_, psb_desc_type
implicit none
type(psb_desc_type), intent(in) :: desc_p
integer(psb_ipk_), intent(in) :: iout
logical, intent(in), optional :: glob,short
end subroutine psb_cdprt
end interface
interface psb_cdins
subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(out) :: ila(:), jla(:)
end subroutine psb_cdinsrc
subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: nz,ja(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(out) :: jla(:)
logical, optional, target, intent(in) :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
end subroutine psb_cdinsc
end interface
interface psb_cdbldext
Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
import :: psb_ipk_, psb_desc_type
Implicit None
Type(psb_desc_type), Intent(in), target :: desc_a
integer(psb_ipk_), intent(in) :: in_list(:)
Type(psb_desc_type), Intent(out) :: desc_ov
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional, target :: mask(:)
integer(psb_ipk_), intent(in),optional :: extype
end Subroutine psb_cd_lstext
end interface
interface psb_cdren
subroutine psb_cdren(trans,iperm,desc_a,info)
import :: psb_ipk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(inout) :: iperm(:)
character, intent(in) :: trans
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cdren
end interface
interface psb_get_overlap
subroutine psb_get_ovrlap(ovrel,desc,info)
import :: psb_ipk_, psb_desc_type
implicit none
integer(psb_ipk_), allocatable, intent(out) :: ovrel(:)
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
end subroutine psb_get_ovrlap
end interface
interface psb_icdasb
subroutine psb_icdasb(desc,info,ext_hv)
import :: psb_ipk_, psb_desc_type
Type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
end module psb_i_tools_mod
end module psb_cd_if_tools_mod
module psb_cd_tools_mod
use psb_const_mod
use psb_cd_if_tools_mod
interface psb_cdall
subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,&
& globalcheck,lidx)
import :: psb_ipk_, psb_desc_type, psb_parts
implicit None
procedure(psb_parts) :: parts
integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl,lidx(:)
integer(psb_ipk_), intent(in) :: flag
logical, intent(in) :: repl, globalcheck
integer(psb_ipk_), intent(out) :: info
type(psb_desc_type), intent(out) :: desc
optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck,lidx
end subroutine psb_cdall
end interface
interface psb_cdasb
module procedure psb_cdasb
end interface
interface psb_get_boundary
module procedure psb_get_boundary
end interface
interface
subroutine psb_cd_switch_ovl_indxmap(desc,info)
import :: psb_ipk_, psb_desc_type
implicit None
include 'parts.fh'
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cd_switch_ovl_indxmap
end interface
contains
subroutine psb_get_boundary(bndel,desc,info)
use psi_mod, only : psi_crea_bnd_elem
implicit none
integer(psb_ipk_), allocatable, intent(out) :: bndel(:)
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
call psi_crea_bnd_elem(bndel,desc,info)
end subroutine psb_get_boundary
subroutine psb_cdasb(desc,info)
Type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
call psb_icdasb(desc,info,ext_hv=.false.)
end subroutine psb_cdasb
end module psb_cd_tools_mod
module psb_base_tools_mod
use psb_iv_tools_mod
use psb_cd_tools_mod
end module psb_base_tools_mod

@ -100,7 +100,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
@ -117,7 +121,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
@ -411,7 +419,11 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
@ -531,7 +543,11 @@ contains
integer(psb_ipk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)

@ -163,20 +163,22 @@ module psb_indx_map_mod
procedure, pass(idxmap) :: l2gs2 => base_l2gs2
procedure, pass(idxmap) :: l2gv1 => base_l2gv1
procedure, pass(idxmap) :: l2gv2 => base_l2gv2
generic, public :: l2g => l2gs1, l2gs2, l2gv1, l2gv2
generic, public :: l2g => l2gs2, l2gv2
generic, public :: l2gip => l2gs1, l2gv1
procedure, pass(idxmap) :: g2ls1 => base_g2ls1
procedure, pass(idxmap) :: g2ls2 => base_g2ls2
procedure, pass(idxmap) :: g2lv1 => base_g2lv1
procedure, pass(idxmap) :: g2lv2 => base_g2lv2
generic, public :: g2l => g2ls1, g2ls2, g2lv1, g2lv2
generic, public :: g2l => g2ls2, g2lv2
generic, public :: g2lip => g2ls1, g2lv1
procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins
generic, public :: g2l_ins => g2ls1_ins, g2ls2_ins,&
& g2lv1_ins, g2lv2_ins
generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins
generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins
procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner
procedure, pass(idxmap) :: init_vl => base_init_vl

@ -133,7 +133,7 @@ contains
end if
idxv(1) = idx
call idxmap%l2g(idxv,info,owned=owned)
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_l2gs1
@ -148,7 +148,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2g(idxout,info,mask,owned)
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine list_l2gs2
@ -221,7 +221,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2g(idxout(1:im),info,mask,owned)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine list_l2gv2
@ -242,7 +242,7 @@ contains
end if
idxv(1) = idx
call idxmap%g2l(idxv,info,owned=owned)
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_g2ls1
@ -257,7 +257,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2l(idxout,info,mask,owned)
call idxmap%g2lip(idxout,info,mask,owned)
end subroutine list_g2ls2
@ -342,7 +342,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l(idxout(1:im),info,mask,owned)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine list_g2lv2
@ -368,9 +368,9 @@ contains
idxv(1) = idx
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2l_ins(idxv,info,lidx=lidxv)
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2l_ins(idxv,info)
call idxmap%g2lip_ins(idxv,info)
end if
idx = idxv(1)
@ -387,7 +387,7 @@ contains
integer, intent(in), optional :: lidx
idxout = idxin
call idxmap%g2l_ins(idxout,info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine list_g2ls2_ins
@ -545,7 +545,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l_ins(idxout(1:im),info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (is > im) info = -3
end subroutine list_g2lv2_ins

@ -117,7 +117,7 @@ contains
end if
idxv(1) = idx
call idxmap%l2g(idxv,info,owned=owned)
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine repl_l2gs1
@ -132,7 +132,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2g(idxout,info,mask,owned)
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine repl_l2gs2
@ -199,7 +199,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2g(idxout(1:im),info,mask,owned)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine repl_l2gv2
@ -220,7 +220,7 @@ contains
end if
idxv(1) = idx
call idxmap%g2l(idxv,info,owned=owned)
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine repl_g2ls1
@ -235,7 +235,7 @@ contains
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2l(idxout,info,mask,owned)
call idxmap%g2lip(idxout,info,mask,owned)
end subroutine repl_g2ls2
@ -335,7 +335,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l(idxout(1:im),info,mask,owned)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine repl_g2lv2
@ -361,9 +361,9 @@ contains
idxv(1) = idx
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2l_ins(idxv,info,lidx=lidxv)
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2l_ins(idxv,info)
call idxmap%g2lip_ins(idxv,info)
end if
idx = idxv(1)
@ -379,7 +379,7 @@ contains
integer, intent(in), optional :: lidx
idxout = idxin
call idxmap%g2l_ins(idxout,info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine repl_g2ls2_ins
@ -484,7 +484,7 @@ contains
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2l_ins(idxout(1:im),info,mask=mask,lidx=lidx)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (is > im) info = -3
end subroutine repl_g2lv2_ins

@ -68,6 +68,7 @@ module psb_s_base_vect_mod
procedure, pass(x) :: bld_n => s_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => s_base_all
procedure, pass(x) :: mold => s_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
@ -219,6 +220,18 @@ contains
end subroutine s_base_all
subroutine s_base_mold(x, y, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_base_vect_type), intent(in) :: x
class(psb_s_base_vect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_s_base_vect_type :: y, stat=info)
end subroutine s_base_mold
!
! Insert a bunch of values at specified positions.
!

@ -100,7 +100,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_vect_type :: x%v,stat=info)
endif
@ -117,7 +121,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_vect_type :: x%v,stat=info)
endif
@ -411,7 +419,11 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_vect_type :: x%v,stat=info)
endif
@ -531,7 +543,11 @@ contains
real(psb_spk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)

@ -30,7 +30,8 @@
!!$
!!$
module psb_tools_mod
use psb_base_tools_mod
use psb_cd_tools_mod
use psb_i_tools_mod
use psb_s_tools_mod
use psb_d_tools_mod
use psb_c_tools_mod

@ -68,6 +68,7 @@ module psb_z_base_vect_mod
procedure, pass(x) :: bld_n => z_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => z_base_all
procedure, pass(x) :: mold => z_base_mold
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
@ -219,6 +220,18 @@ contains
end subroutine z_base_all
subroutine z_base_mold(x, y, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_base_vect_type), intent(in) :: x
class(psb_z_base_vect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_z_base_vect_type :: y, stat=info)
end subroutine z_base_mold
!
! Insert a bunch of values at specified positions.
!

@ -100,7 +100,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_vect_type :: x%v,stat=info)
endif
@ -117,7 +121,11 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_vect_type :: x%v,stat=info)
endif
@ -411,7 +419,11 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_vect_type :: x%v,stat=info)
endif
@ -531,7 +543,11 @@ contains
complex(psb_dpk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)

@ -413,6 +413,13 @@ module psi_i_mod
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_updr2
subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_upd_vect
end interface
interface psi_ovrl_save
@ -430,6 +437,13 @@ module psi_i_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_saver2
subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_save_vect
end interface
interface psi_ovrl_restore
@ -447,6 +461,13 @@ module psi_i_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_restrr2
subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_restr_vect
end interface
end module psi_i_mod

@ -1554,9 +1554,11 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
! allocate(tmp(nac),stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_) call tmpv%mlt(cone,d%v(1:nac),x,czero,info)
if (info == psb_success_)&
@ -1579,10 +1581,13 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (beta == czero) then
call a%inner_cssm(alpha,x,czero,y,info,trans)
if (info == psb_success_) call y%mlt(d%v(1:nar),info)
!!$ if (info == psb_success_) call inner_vscal1(nar,d,y)
else
! allocate(tmp(nar),stat=info)
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_)&
& call a%inner_cssm(alpha,x,czero,tmpv,info,trans)

@ -1554,9 +1554,11 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
! allocate(tmp(nac),stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_) call tmpv%mlt(done,d%v(1:nac),x,dzero,info)
if (info == psb_success_)&
@ -1579,10 +1581,13 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (beta == dzero) then
call a%inner_cssm(alpha,x,dzero,y,info,trans)
if (info == psb_success_) call y%mlt(d%v(1:nar),info)
!!$ if (info == psb_success_) call inner_vscal1(nar,d,y)
else
! allocate(tmp(nar),stat=info)
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_)&
& call a%inner_cssm(alpha,x,dzero,tmpv,info,trans)

@ -1554,9 +1554,11 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
! allocate(tmp(nac),stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_) call tmpv%mlt(sone,d%v(1:nac),x,szero,info)
if (info == psb_success_)&
@ -1579,10 +1581,13 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (beta == szero) then
call a%inner_cssm(alpha,x,szero,y,info,trans)
if (info == psb_success_) call y%mlt(d%v(1:nar),info)
!!$ if (info == psb_success_) call inner_vscal1(nar,d,y)
else
! allocate(tmp(nar),stat=info)
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_)&
& call a%inner_cssm(alpha,x,szero,tmpv,info,trans)

@ -1554,9 +1554,11 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
! allocate(tmp(nac),stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_) call tmpv%mlt(zone,d%v(1:nac),x,zzero,info)
if (info == psb_success_)&
@ -1579,10 +1581,13 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (beta == zzero) then
call a%inner_cssm(alpha,x,zzero,y,info,trans)
if (info == psb_success_) call y%mlt(d%v(1:nar),info)
!!$ if (info == psb_success_) call inner_vscal1(nar,d,y)
else
! allocate(tmp(nar),stat=info)
#ifdef HAVE_MOLD
allocate(tmpv, mold=y,stat=info)
#else
call y%mold(tmpv,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_)&
& call a%inner_cssm(alpha,x,zzero,tmpv,info,trans)

@ -79,7 +79,7 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
do i=1,n_col
vl(i) = i
end do
call desc%indxmap%l2g(vl(1:n_col),info)
call desc%indxmap%l2gip(vl(1:n_col),info)
if (info /= psb_success_) then
ierr(1)=info
@ -101,7 +101,7 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
& call desc%indxmap%init(iictxt,vl(1:n_row),info)
if (info == psb_success_) call psb_cd_set_bld(desc,info)
if (info == psb_success_) &
& call desc%indxmap%g2l_ins(vl(n_row+1:n_col),info)
& call desc%indxmap%g2lip_ins(vl(n_row+1:n_col),info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&

@ -4,7 +4,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_base_tools_mod, psb_protect_name => psb_cdall
use psb_cd_tools_mod, psb_protect_name => psb_cdall
use psi_mod
implicit None
procedure(psb_parts) :: parts

@ -250,3 +250,81 @@ subroutine psb_iallocv(x, desc_a, info,n)
end subroutine psb_iallocv
subroutine psb_ialloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_ialloc_vect
use psi_mod
implicit none
!....parameters...
type(psb_i_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: ictxt, int_err(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
allocate(psb_i_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)')
goto 9999
endif
call x%zero()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_ialloc_vect

@ -251,3 +251,82 @@ subroutine psb_iasbv(x, desc_a, info)
end subroutine psb_iasbv
subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_iasb_vect
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
info = psb_success_
if (psb_errstatus_fatal()) return
int_err(1) = 0
name = 'psb_igeasb_v'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (present(mold)) then
call x%cnv(mold)
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_iasb_vect

@ -198,3 +198,63 @@ subroutine psb_ifreev(x, desc_a,info)
return
end subroutine psb_ifreev
subroutine psb_ifree_vect(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_ifree_vect
implicit none
!....parameters...
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name='psb_ifreev'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
call x%free(info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_ifree_vect

@ -45,7 +45,7 @@
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl)
subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iinsvi
use psi_mod
implicit none
@ -62,12 +62,14 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@ -127,9 +129,17 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl)
else
dupl_ = psb_dupl_ovwrt_
endif
call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.)
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
@ -225,7 +235,7 @@ end subroutine psb_iinsvi
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl)
subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iinsi
use psi_mod
implicit none
@ -243,12 +253,14 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,loc_row,j,n,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np,me,dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@ -310,8 +322,18 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl)
call psb_errpush(info,name)
goto 9999
endif
call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.)
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
@ -366,3 +388,126 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl)
return
end subroutine psb_iinsi
subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_iins_vect
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:)
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_iinsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.)
end if
call x%ins(m,irl,val,dupl_,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_iins_vect

@ -179,7 +179,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact)
endif
act = psb_toupper(act)
call desc_a%indxmap%l2g(x,info)
call desc_a%indxmap%l2gip(x,info)
if (info /= psb_success_) then
select case(act)

@ -340,7 +340,7 @@ dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN([PAC_ARG_SERIAL_MPI],
[
AC_MSG_CHECKING([whether we want serial (fake) mpi])
AC_MSG_CHECKING([whether we want serial mpi stubs])
AC_ARG_ENABLE(serial,
AC_HELP_STRING([--enable-serial],
[Specify whether to enable a fake mpi library to run in serial mode. ]),
@ -1057,7 +1057,9 @@ dnl @category InstalledPackages
dnl @author Steven G. Johnson <stevenj@alum.mit.edu>
dnl @version 2001-12-13
dnl @license GPLWithACException
dnl
dnl modified by salvatore.filippone@uniroma2.it
dnl
dnl shifted check for ESSL as it was generating erroneous results on
dnl AIX SP5.
dnl Modified with new name to handle Fortran compilers (such as NAG)
@ -1067,7 +1069,7 @@ dnl would fail even when linking in the compiler's library)
AC_DEFUN([PAC_BLAS], [
AC_PREREQ(2.50)
AC_REQUIRE([AC_F77_LIBRARY_LDFLAGS])
dnl AC_REQUIRE([AC_FC_LIBRARY_LDFLAGS])
pac_blas_ok=no
AC_ARG_WITH(blas,
@ -1080,21 +1082,20 @@ case $with_blas in
esac
# Get fortran linker names of BLAS functions to check for.
AC_F77_FUNC(sgemm)
AC_F77_FUNC(dgemm)
#AC_FC_FUNC(sgemm)
#AC_FC_FUNC(dgemm)
pac_blas_save_LIBS="$LIBS"
LIBS="$LIBS $FLIBS"
#pac_blas_save_LIBS="$LIBS"
#LIBS="$LIBS $FLIBS"
AC_LANG([Fortran])
# First, check BLAS_LIBS environment variable
if test $pac_blas_ok = no; then
if test "x$BLAS_LIBS" != x; then
save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS"
AC_LANG([Fortran])
AC_MSG_CHECKING([for sgemm in $BLAS_LIBS])
AC_TRY_LINK_FUNC(sgemm, [pac_blas_ok=yes], [BLAS_LIBS=""])
AC_MSG_RESULT($pac_blas_ok)
AC_LANG([C])
LIBS="$save_LIBS"
fi
fi
@ -1102,6 +1103,7 @@ fi
# BLAS in ATLAS library? (http://math-atlas.sourceforge.net/)
if test $pac_blas_ok = no; then
AC_LANG([C])
AC_CHECK_LIB(atlas, ATL_xerbla,
[AC_LANG([Fortran])
AC_CHECK_LIB(f77blas, sgemm,
@ -1111,7 +1113,6 @@ if test $pac_blas_ok = no; then
BLAS_LIBS="-lcblas -lf77blas -latlas"],
[], [-lf77blas -latlas])],
[], [-latlas])])
AC_LANG([C])
fi
@ -1124,17 +1125,16 @@ if test $pac_blas_ok = no; then
[pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas"],
[], [-lblas])],
[], [-lblas])])
AC_LANG([C])
fi
# BLAS in Alpha CXML library?
if test $pac_blas_ok = no; then
AC_CHECK_LIB(cxml, $sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lcxml"])
AC_CHECK_LIB(cxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-lcxml"])
fi
# BLAS in Alpha DXML library? (now called CXML, see above)
if test $pac_blas_ok = no; then
AC_CHECK_LIB(dxml, $sgemm, [pac_blas_ok=yes;BLAS_LIBS="-ldxml"])
AC_CHECK_LIB(dxml, sgemm, [pac_blas_ok=yes;BLAS_LIBS="-ldxml"])
fi
@ -1142,7 +1142,7 @@ fi
if test $pac_blas_ok = no; then
if test "x$GCC" != xyes; then # only works with Sun CC
AC_CHECK_LIB(sunmath, acosp,
[AC_CHECK_LIB(sunperf, $sgemm,
[AC_CHECK_LIB(sunperf, sgemm,
[BLAS_LIBS="-xlic_lib=sunperf -lsunmath"
pac_blas_ok=yes],[],[-lsunmath])])
@ -1151,7 +1151,7 @@ fi
# BLAS in SCSL library? (SGI/Cray Scientific Library)
if test $pac_blas_ok = no; then
AC_CHECK_LIB(scs, $sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lscs"])
AC_CHECK_LIB(scs, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lscs"])
fi
# BLAS in SGIMATH library?
@ -1163,15 +1163,15 @@ fi
# BLAS in IBM ESSL library? (requires generic BLAS lib, too)
if test $pac_blas_ok = no; then
AC_CHECK_LIB(blas, $sgemm,
[AC_CHECK_LIB(essl, $sgemm,
[AC_CHECK_LIB(essl, sgemm,
[pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas"],
[], [-lblas $FLIBS])])
fi
# BLAS linked to by default? (happens on some supercomputers)
if test $pac_blas_ok = no; then
save_LIBS="$LIBS"; LIBS="$LIBS"
AC_TRY_LINK_FUNC($sgemm, [pac_blas_ok=yes], [BLAS_LIBS=""])
dnl AC_CHECK_FUNC($sgemm, [pac_blas_ok=yes])
AC_TRY_LINK_FUNC(sgemm, [pac_blas_ok=yes], [BLAS_LIBS=""])
dnl AC_CHECK_FUNC(sgemm, [pac_blas_ok=yes])
LIBS="$save_LIBS"
fi
@ -1179,10 +1179,6 @@ fi
if test $pac_blas_ok = no; then
AC_LANG([Fortran])
AC_CHECK_LIB(blas, sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lblas"])
AC_LANG([C])
if test $pac_blas_ok = no; then
AC_CHECK_LIB(blas, $sgemm, [pac_blas_ok=yes; BLAS_LIBS="-lblas"])
fi
fi
AC_SUBST(BLAS_LIBS)
@ -1256,7 +1252,7 @@ case $with_lapack in
esac
# Get fortran linker name of LAPACK function to check for.
AC_F77_FUNC(cheev)
#AC_FC_FUNC(cheev)
# We cannot use LAPACK if BLAS is not found
if test "x$pac_blas_ok" != xyes; then

8218
configure vendored

File diff suppressed because it is too large Load Diff

@ -377,7 +377,8 @@ if test "X$FCOPT" == "X" ; then
FCOPT="-O3 $FCOPT"
elif test "X$psblas_cv_fc" == X"xlf" ; then
# XL compiler : consider using -qarch=auto
FCOPT="-O3 -qarch=auto -qfixed -qsuffix=f=f:cpp=F $FCOPT"
FCOPT="-O3 -qarch=auto -qfixed -qsuffix=f=f:cpp=F -qlanglvl=extended $FCOPT"
FCFLAGS="-qhalt=e $FCFLAGS"
elif test "X$psblas_cv_fc" == X"ifc" ; then
# other compilers ..
FCOPT="-O3 $FCOPT"
@ -411,7 +412,7 @@ if test "X$F90COPT" == "X" ; then
F90COPT="-O3 $F90COPT"
elif test "X$psblas_cv_fc" == X"xlf" ; then
# XL compiler : consider using -qarch=auto
F90COPT="-O3 -qarch=auto -qsuffix=f=f90:cpp=F90 $F90COPT"
F90COPT="-O3 -qarch=auto -qsuffix=f=f90:cpp=F90 -qlanglvl=extended $F90COPT"
elif test "X$psblas_cv_fc" == X"ifc" ; then
# other compilers ..
F90COPT="-O3 $F90COPT"
@ -644,11 +645,11 @@ AR="${AR} -cur"
# Right now it is a matter of user's taste when linking custom applications.
# But PSBLAS examples could take advantage of these libraries, too.
AC_LANG([C])
PAC_BLAS([], [AC_MSG_ERROR([[Cannot find BLAS library, specify a path using --with-blas=DIR/LIB (for example --with-blas=/usr/path/lib/libcxml.a)]])])
PAC_LAPACK(
[FDEFINES="$psblas_cv_define_prepend-DHAVE_LAPACK $FDEFINES"],
)
AC_LANG([C])
###############################################################################

Loading…
Cancel
Save