Merge branch 'repackage' into psblas-bgmres, fixes to resolve merge

psblas-bgmres
sfilippone 7 months ago
commit c1e4f9c2b1

@ -67,6 +67,26 @@ UTILMODNAME=@UTILMODNAME@
CBINDLIBNAME=libpsb_cbind.a
CUDAD=@CUDAD@
CUDALD=@CUDALD@
LCUDA=@LCUDA@
SPGPU_LIBS=@SPGPU_LIBS@
CUDA_DIR=@CUDA_DIR@
CUDA_DEFINES=@CUDA_DEFINES@
CUDA_INCLUDES=@CUDA_INCLUDES@
CUDA_LIBS=@CUDA_LIBS@
CUDA_VERSION=@CUDA_VERSION@
CUDA_SHORT_VERSION=@CUDA_SHORT_VERSION@
NVCC=@CUDA_NVCC@
CUDEFINES=@CUDEFINES@
.SUFFIXES: .cu
.cu.o:
$(NVCC) $(CINCLUDES) $(CDEFINES) $(CUDEFINES) -c $<
@PSBLASRULES@
PSBGPULDLIBS=$(LCUDA) $(SPGPU_LIBS) $(CUDA_LIBS) $(PSBLDLIBS) $(LIBS)

@ -1,6 +1,6 @@
include Make.inc
all: dirs based precd kryld utild cbindd libd
all: dirs based precd kryld utild cbindd extd $(CUDAD) libd
@echo "====================================="
@echo "PSBLAS libraries Compilation Successful."
@ -12,15 +12,20 @@ dirs:
precd: based
utild: based
kryld: precd
extd: based
cudad: extd
cbindd: based precd kryld utild
libd: based precd kryld utild cbindd
libd: based precd kryld utild cbindd extd $(CUDALD)
$(MAKE) -C base lib
$(MAKE) -C prec lib
$(MAKE) -C krylov lib
$(MAKE) -C util lib
$(MAKE) -C cbind lib
$(MAKE) -C ext lib
cudald: cudad
$(MAKE) -C cuda lib
based:
$(MAKE) -C base objs
@ -32,6 +37,10 @@ utild:
$(MAKE) -C util objs
cbindd:
$(MAKE) -C cbind objs
extd: based
$(MAKE) -C ext objs
cudad: based extd
$(MAKE) -C cuda objs
install: all
@ -56,6 +65,8 @@ clean:
$(MAKE) -C krylov clean
$(MAKE) -C util clean
$(MAKE) -C cbind clean
$(MAKE) -C ext clean
$(MAKE) -C cuda clean
check: all
make check -C test/serial
@ -71,6 +82,8 @@ veryclean: cleanlib
cd krylov && $(MAKE) veryclean
cd util && $(MAKE) veryclean
cd cbind && $(MAKE) veryclean
cd ext && $(MAKE) veryclean
cd cuda && $(MAKE) veryclean
cd test/fileread && $(MAKE) clean
cd test/pargen && $(MAKE) clean
cd test/util && $(MAKE) clean

@ -1,4 +1,4 @@
PSBLAS library, version 3.8
PSBLAS library, version 3.9
===========================
The architecture of the Fortran 2003 sparse BLAS is described in:
@ -40,6 +40,15 @@ The main reference for the serial sparse BLAS is:
>linear algebra subprograms for sparse matrices: a user level interface,
>ACM Trans. Math. Softw., 23(3), 379-401, 1997.
CUDA and GPU support
--------------------
This version of PSBLAS incorporates into a single package three
entities that were previouslty separated:
1. PSBLAS -- the base library
2. PSBLAS-EXT -- a library providing additional storage formats
3. SPGPU -- a package of kernels for NVIDIA GPUs originally
written by Davide Barbieri and Salvatore Filippone;
see the license file cuda/License-spgpu.md
INSTALLING
----------
@ -61,6 +70,11 @@ prerequisites (see also SERIAL below):
specify `--with-amd` (see `./configure --help` for more details).
We use the C interface to AMD.
5. If you have CUDA available, use
--with-cuda=<path> to specify the CUDA toolkit location
--with-cudacc=XX,YY,ZZ to specify a list of target CCs (compute
capabilities) to compile the CUDA code for.
The configure script will generate a Make.inc file suitable for building
the library. The script is capable of recognizing the needed libraries
with their default names; if they are in unusual places consider adding

@ -191,7 +191,9 @@ subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -191,7 +191,9 @@ subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx, &
logical, parameter :: usersend=.false.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -676,7 +678,9 @@ subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx, &
logical, parameter :: usersend=.false.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -195,7 +195,9 @@ subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,&
logical, parameter :: usersend=.false.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -688,7 +690,9 @@ subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,&
logical, parameter :: usersend=.false.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#if !defined(FLANG)
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_

@ -87,7 +87,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
integer(psb_lpk_) :: mglob, ih
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me
logical, parameter :: gettime=.true., debug=.false.
logical, parameter :: debug=.false.
integer(psb_mpk_) :: xchg_alg
logical, parameter :: do_timings=.false.
integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
@ -132,10 +132,6 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
goto 9999
end if
if (gettime) then
t0 = psb_wtime()
end if
nadj = size(adj)
nidx = size(idx)
call psb_realloc(nidx,iprc,info)

@ -99,6 +99,33 @@ module psi_c_serial_mod
end subroutine psi_caxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_cabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_spk_
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_spk_), intent (in) :: x(:)
complex(psb_spk_), intent (inout) :: y(:)
complex(psb_spk_), intent (inout) :: z(:)
complex(psb_spk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_cabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_cxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_spk_
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_spk_), intent (in) :: x(:)
complex(psb_spk_), intent (inout) :: y(:)
complex(psb_spk_), intent (inout) :: z(:)
complex(psb_spk_), intent (inout) :: w(:)
complex(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_cxyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_spk_

@ -99,6 +99,33 @@ module psi_d_serial_mod
end subroutine psi_daxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_dabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_dpk_
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_dpk_), intent (in) :: x(:)
real(psb_dpk_), intent (inout) :: y(:)
real(psb_dpk_), intent (inout) :: z(:)
real(psb_dpk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_dxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_dpk_
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_dpk_), intent (in) :: x(:)
real(psb_dpk_), intent (inout) :: y(:)
real(psb_dpk_), intent (inout) :: z(:)
real(psb_dpk_), intent (inout) :: w(:)
real(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dxyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_dpk_

@ -99,6 +99,33 @@ module psi_e_serial_mod
end subroutine psi_eaxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_eabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_epk_), intent (in) :: x(:)
integer(psb_epk_), intent (inout) :: y(:)
integer(psb_epk_), intent (inout) :: z(:)
integer(psb_epk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_eabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_exyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_epk_), intent (in) :: x(:)
integer(psb_epk_), intent (inout) :: y(:)
integer(psb_epk_), intent (inout) :: z(:)
integer(psb_epk_), intent (inout) :: w(:)
integer(psb_epk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_exyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_egthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_

@ -99,6 +99,33 @@ module psi_i2_serial_mod
end subroutine psi_i2axpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_i2abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (inout) :: y(:)
integer(psb_i2pk_), intent (inout) :: z(:)
integer(psb_i2pk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2abgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_i2xyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (inout) :: y(:)
integer(psb_i2pk_), intent (inout) :: z(:)
integer(psb_i2pk_), intent (inout) :: w(:)
integer(psb_i2pk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2xyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_

@ -99,6 +99,33 @@ module psi_m_serial_mod
end subroutine psi_maxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_mabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_mpk_), intent (in) :: x(:)
integer(psb_mpk_), intent (inout) :: y(:)
integer(psb_mpk_), intent (inout) :: z(:)
integer(psb_mpk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_mabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_mxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_mpk_), intent (in) :: x(:)
integer(psb_mpk_), intent (inout) :: y(:)
integer(psb_mpk_), intent (inout) :: z(:)
integer(psb_mpk_), intent (inout) :: w(:)
integer(psb_mpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_mxyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_

@ -99,6 +99,33 @@ module psi_s_serial_mod
end subroutine psi_saxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_sabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_spk_
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_spk_), intent (in) :: x(:)
real(psb_spk_), intent (inout) :: y(:)
real(psb_spk_), intent (inout) :: z(:)
real(psb_spk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_sxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_spk_
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_spk_), intent (in) :: x(:)
real(psb_spk_), intent (inout) :: y(:)
real(psb_spk_), intent (inout) :: z(:)
real(psb_spk_), intent (inout) :: w(:)
real(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sxyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_spk_

@ -99,6 +99,33 @@ module psi_z_serial_mod
end subroutine psi_zaxpbyv2
end interface psb_geaxpby
interface psi_abgdxyz
subroutine psi_zabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
import :: psb_ipk_, psb_dpk_
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_dpk_), intent (in) :: x(:)
complex(psb_dpk_), intent (inout) :: y(:)
complex(psb_dpk_), intent (inout) :: z(:)
complex(psb_dpk_), intent (in) :: alpha, beta,gamma,delta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zabgdxyz
end interface psi_abgdxyz
interface psi_xyzw
subroutine psi_zxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
import :: psb_ipk_, psb_dpk_
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_dpk_), intent (in) :: x(:)
complex(psb_dpk_), intent (inout) :: y(:)
complex(psb_dpk_), intent (inout) :: z(:)
complex(psb_dpk_), intent (inout) :: w(:)
complex(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zxyzw
end interface psi_xyzw
interface psi_gth
subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_dpk_

@ -136,9 +136,9 @@ module psb_const_mod
!
! Version
!
character(len=*), parameter :: psb_version_string_ = "3.8.0"
character(len=*), parameter :: psb_version_string_ = "3.9.0"
integer(psb_ipk_), parameter :: psb_version_major_ = 3
integer(psb_ipk_), parameter :: psb_version_minor_ = 8
integer(psb_ipk_), parameter :: psb_version_minor_ = 9
integer(psb_ipk_), parameter :: psb_patchlevel_ = 0
!

@ -143,6 +143,20 @@ module psb_c_psblas_mod
end subroutine psb_caxpby
end interface
interface psb_abgdxyz
subroutine psb_cabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_vect_type, psb_cspmat_type
type(psb_c_vect_type), intent (inout) :: x
type(psb_c_vect_type), intent (inout) :: y
type(psb_c_vect_type), intent (inout) :: z
complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cabgdxyz_vect
end interface psb_abgdxyz
interface psb_geamax
function psb_camax(x, desc_a, info, jx,global)
import :: psb_desc_type, psb_spk_, psb_ipk_, &

@ -216,6 +216,20 @@ module psb_d_psblas_mod
end function psb_dqrfact
end interface
interface psb_abgdxyz
subroutine psb_dabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_vect_type, psb_dspmat_type
type(psb_d_vect_type), intent (inout) :: x
type(psb_d_vect_type), intent (inout) :: y
type(psb_d_vect_type), intent (inout) :: z
real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_dabgdxyz_vect
end interface psb_abgdxyz
interface psb_geamax
function psb_damax(x, desc_a, info, jx,global)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &

@ -143,6 +143,20 @@ module psb_s_psblas_mod
end subroutine psb_saxpby
end interface
interface psb_abgdxyz
subroutine psb_sabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_vect_type, psb_sspmat_type
type(psb_s_vect_type), intent (inout) :: x
type(psb_s_vect_type), intent (inout) :: y
type(psb_s_vect_type), intent (inout) :: z
real(psb_spk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_sabgdxyz_vect
end interface psb_abgdxyz
interface psb_geamax
function psb_samax(x, desc_a, info, jx,global)
import :: psb_desc_type, psb_spk_, psb_ipk_, &

@ -143,6 +143,20 @@ module psb_z_psblas_mod
end subroutine psb_zaxpby
end interface
interface psb_abgdxyz
subroutine psb_zabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_vect_type, psb_zspmat_type
type(psb_z_vect_type), intent (inout) :: x
type(psb_z_vect_type), intent (inout) :: y
type(psb_z_vect_type), intent (inout) :: z
complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zabgdxyz_vect
end interface psb_abgdxyz
interface psb_geamax
function psb_zamax(x, desc_a, info, jx,global)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &

@ -155,6 +155,9 @@ module psb_c_base_vect_mod
procedure, pass(z) :: axpby_v2 => c_base_axpby_v2
procedure, pass(z) :: axpby_a2 => c_base_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => c_base_abgdxyz
procedure, pass(w) :: xyzw => c_base_xyzw
!
! Vector by vector multiplication. Need all variants
! to handle multiple requirements from preconditioners
@ -1018,7 +1021,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine c_base_axpby_v(m,alpha, x, beta, y, info)
@ -1047,7 +1050,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be returned
!! \param info return code
@ -1078,7 +1081,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x(:) The array to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine c_base_axpby_a(m,alpha, x, beta, y, info)
@ -1126,6 +1129,64 @@ contains
end subroutine c_base_axpby_a2
!
! ABGDXYZ is invoked via Z, hence the structure below.
!
!
!> Function base_abgdxyz
!! \memberof psb_c_base_vect_type
!! \brief ABGDXYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param beta scalar beta
!! \param gamma scalar gamma
!! \param delta scalar delta
!! \param x The class(base_vect) to be added
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be added
!! \param info return code
!!
subroutine c_base_abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_c_base_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(inout) :: y
class(psb_c_base_vect_type), intent(inout) :: z
complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(alpha/=czero)) call x%sync()
if (y%is_dev().and.(beta/=czero)) call y%sync()
if (z%is_dev().and.(delta/=czero)) call z%sync()
call psi_abgdxyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info)
call y%set_host()
call z%set_host()
end subroutine c_base_abgdxyz
subroutine c_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_c_base_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(inout) :: y
class(psb_c_base_vect_type), intent(inout) :: z
class(psb_c_base_vect_type), intent(inout) :: w
complex(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(a/=czero)) call x%sync()
if (y%is_dev().and.(b/=czero)) call y%sync()
if (z%is_dev().and.(d/=czero)) call z%sync()
if (w%is_dev().and.(f/=czero)) call w%sync()
call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info)
call y%set_host()
call z%set_host()
call w%set_host()
end subroutine c_base_xyzw
!
! Multiple variants of two operations:

@ -579,6 +579,110 @@ module psb_c_csr_mat_mod
end subroutine psb_c_csr_scals
end interface
type, extends(psb_c_csr_sparse_mat) :: psb_c_ecsr_sparse_mat
!> Number of non-empty rows
integer(psb_ipk_) :: nnerws
!> Indices of non-empty rows
integer(psb_ipk_), allocatable :: nerwp(:)
contains
procedure, nopass :: get_fmt => c_ecsr_get_fmt
! procedure, pass(a) :: csmm => psb_c_ecsr_csmm
procedure, pass(a) :: csmv => psb_c_ecsr_csmv
procedure, pass(a) :: cp_from_coo => psb_c_cp_ecsr_from_coo
procedure, pass(a) :: cp_from_fmt => psb_c_cp_ecsr_from_fmt
procedure, pass(a) :: mv_from_coo => psb_c_mv_ecsr_from_coo
procedure, pass(a) :: mv_from_fmt => psb_c_mv_ecsr_from_fmt
procedure, pass(a) :: cmp_nerwp => psb_c_ecsr_cmp_nerwp
procedure, pass(a) :: free => c_ecsr_free
procedure, pass(a) :: mold => psb_c_ecsr_mold
end type psb_c_ecsr_sparse_mat
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_csmv
interface
subroutine psb_c_ecsr_csmv(alpha,a,x,beta,y,info,trans)
import
class(psb_c_ecsr_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta, x(:)
complex(psb_spk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_c_ecsr_csmv
end interface
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo
interface
subroutine psb_c_ecsr_cmp_nerwp(a,info)
import
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_ecsr_cmp_nerwp
end interface
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo
interface
subroutine psb_c_cp_ecsr_from_coo(a,b,info)
import
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_cp_ecsr_from_coo
end interface
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt
interface
subroutine psb_c_cp_ecsr_from_fmt(a,b,info)
import
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_cp_ecsr_from_fmt
end interface
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo
interface
subroutine psb_c_mv_ecsr_from_coo(a,b,info)
import
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_mv_ecsr_from_coo
end interface
!> \memberof psb_c_ecsr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt
interface
subroutine psb_c_mv_ecsr_from_fmt(a,b,info)
import
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_mv_ecsr_from_fmt
end interface
!> \memberof psb_c_ecsr_sparse_mat
!| \see psb_base_mat_mod::psb_base_mold
interface
subroutine psb_c_ecsr_mold(a,b,info)
import
class(psb_c_ecsr_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_ecsr_mold
end interface
!> \namespace psb_base_mod \class psb_lc_csr_sparse_mat
!! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat
!!
@ -1178,6 +1282,26 @@ contains
function c_ecsr_get_fmt() result(res)
implicit none
character(len=5) :: res
res = 'ECSR'
end function c_ecsr_get_fmt
subroutine c_ecsr_free(a)
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
if (allocated(a%nerwp)) deallocate(a%nerwp)
a%nnerws = 0
call a%psb_c_csr_sparse_mat%free()
return
end subroutine c_ecsr_free
! == ===================================
!
!

@ -79,12 +79,14 @@
module psb_c_mat_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat, psb_lc_csr_sparse_mat
use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat, psb_lc_csr_sparse_mat,&
& psb_c_ecsr_sparse_mat
use psb_c_csc_mat_mod, only : psb_c_csc_sparse_mat, psb_lc_csc_sparse_mat
type :: psb_cspmat_type
class(psb_c_base_sparse_mat), allocatable :: a
class(psb_c_base_sparse_mat), allocatable :: ad, and
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_lc_coo_sparse_mat), allocatable :: rmta
@ -202,6 +204,7 @@ module psb_c_mat_mod
procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_c_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_c_split_nd
procedure, pass(a) :: clone => psb_cspmat_clone
procedure, pass(a) :: move_alloc => psb_cspmat_type_move
!
@ -840,6 +843,18 @@ module psb_c_mat_mod
!
!
interface
subroutine psb_c_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_c_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_c_split_nd
end interface
!
! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target
@ -859,7 +874,6 @@ module psb_c_mat_mod
end subroutine psb_c_cscnv
end interface
interface
subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
@ -871,7 +885,6 @@ module psb_c_mat_mod
end subroutine psb_c_cscnv_ip
end interface
interface
subroutine psb_c_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat

@ -102,6 +102,9 @@ module psb_c_vect_mod
procedure, pass(z) :: axpby_v2 => c_vect_axpby_v2
procedure, pass(z) :: axpby_a2 => c_vect_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => c_vect_abgdxyz
procedure, pass(z) :: xyzw => c_vect_xyzw
procedure, pass(y) :: mlt_v => c_vect_mlt_v
procedure, pass(y) :: mlt_a => c_vect_mlt_a
procedure, pass(z) :: mlt_a_2 => c_vect_mlt_a_2
@ -771,6 +774,38 @@ contains
end subroutine c_vect_axpby_a2
subroutine c_vect_abgdxyz(m,alpha,beta,gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_vect_type), intent(inout) :: y
class(psb_c_vect_type), intent(inout) :: z
complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (allocated(z%v)) &
call z%v%abgdxyz(m,alpha,beta,gamma,delta,x%v,y%v,info)
end subroutine c_vect_abgdxyz
subroutine c_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_vect_type), intent(inout) :: y
class(psb_c_vect_type), intent(inout) :: z
class(psb_c_vect_type), intent(inout) :: w
complex(psb_spk_), intent (in) :: a, b, c, d, e, f
integer(psb_ipk_), intent(out) :: info
if (allocated(w%v)) &
call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info)
end subroutine c_vect_xyzw
subroutine c_vect_mlt_v(x, y, info)
use psi_serial_mod
implicit none

@ -155,6 +155,9 @@ module psb_d_base_vect_mod
procedure, pass(z) :: axpby_v2 => d_base_axpby_v2
procedure, pass(z) :: axpby_a2 => d_base_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => d_base_abgdxyz
procedure, pass(w) :: xyzw => d_base_xyzw
!
! Vector by vector multiplication. Need all variants
! to handle multiple requirements from preconditioners
@ -1025,7 +1028,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine d_base_axpby_v(m,alpha, x, beta, y, info)
@ -1054,7 +1057,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be returned
!! \param info return code
@ -1085,7 +1088,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x(:) The array to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine d_base_axpby_a(m,alpha, x, beta, y, info)
@ -1133,6 +1136,64 @@ contains
end subroutine d_base_axpby_a2
!
! ABGDXYZ is invoked via Z, hence the structure below.
!
!
!> Function base_abgdxyz
!! \memberof psb_d_base_vect_type
!! \brief ABGDXYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param beta scalar beta
!! \param gamma scalar gamma
!! \param delta scalar delta
!! \param x The class(base_vect) to be added
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be added
!! \param info return code
!!
subroutine d_base_abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_d_base_vect_type), intent(inout) :: z
real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(alpha/=dzero)) call x%sync()
if (y%is_dev().and.(beta/=dzero)) call y%sync()
if (z%is_dev().and.(delta/=dzero)) call z%sync()
call psi_abgdxyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info)
call y%set_host()
call z%set_host()
end subroutine d_base_abgdxyz
subroutine d_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_d_base_vect_type), intent(inout) :: z
class(psb_d_base_vect_type), intent(inout) :: w
real(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(a/=dzero)) call x%sync()
if (y%is_dev().and.(b/=dzero)) call y%sync()
if (z%is_dev().and.(d/=dzero)) call z%sync()
if (w%is_dev().and.(f/=dzero)) call w%sync()
call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info)
call y%set_host()
call z%set_host()
call w%set_host()
end subroutine d_base_xyzw
!
! Multiple variants of two operations:

@ -579,6 +579,110 @@ module psb_d_csr_mat_mod
end subroutine psb_d_csr_scals
end interface
type, extends(psb_d_csr_sparse_mat) :: psb_d_ecsr_sparse_mat
!> Number of non-empty rows
integer(psb_ipk_) :: nnerws
!> Indices of non-empty rows
integer(psb_ipk_), allocatable :: nerwp(:)
contains
procedure, nopass :: get_fmt => d_ecsr_get_fmt
! procedure, pass(a) :: csmm => psb_d_ecsr_csmm
procedure, pass(a) :: csmv => psb_d_ecsr_csmv
procedure, pass(a) :: cp_from_coo => psb_d_cp_ecsr_from_coo
procedure, pass(a) :: cp_from_fmt => psb_d_cp_ecsr_from_fmt
procedure, pass(a) :: mv_from_coo => psb_d_mv_ecsr_from_coo
procedure, pass(a) :: mv_from_fmt => psb_d_mv_ecsr_from_fmt
procedure, pass(a) :: cmp_nerwp => psb_d_ecsr_cmp_nerwp
procedure, pass(a) :: free => d_ecsr_free
procedure, pass(a) :: mold => psb_d_ecsr_mold
end type psb_d_ecsr_sparse_mat
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_csmv
interface
subroutine psb_d_ecsr_csmv(alpha,a,x,beta,y,info,trans)
import
class(psb_d_ecsr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_d_ecsr_csmv
end interface
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo
interface
subroutine psb_d_ecsr_cmp_nerwp(a,info)
import
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_ecsr_cmp_nerwp
end interface
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo
interface
subroutine psb_d_cp_ecsr_from_coo(a,b,info)
import
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_cp_ecsr_from_coo
end interface
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt
interface
subroutine psb_d_cp_ecsr_from_fmt(a,b,info)
import
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_cp_ecsr_from_fmt
end interface
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo
interface
subroutine psb_d_mv_ecsr_from_coo(a,b,info)
import
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_mv_ecsr_from_coo
end interface
!> \memberof psb_d_ecsr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt
interface
subroutine psb_d_mv_ecsr_from_fmt(a,b,info)
import
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_mv_ecsr_from_fmt
end interface
!> \memberof psb_d_ecsr_sparse_mat
!| \see psb_base_mat_mod::psb_base_mold
interface
subroutine psb_d_ecsr_mold(a,b,info)
import
class(psb_d_ecsr_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_ecsr_mold
end interface
!> \namespace psb_base_mod \class psb_ld_csr_sparse_mat
!! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat
!!
@ -1178,6 +1282,26 @@ contains
function d_ecsr_get_fmt() result(res)
implicit none
character(len=5) :: res
res = 'ECSR'
end function d_ecsr_get_fmt
subroutine d_ecsr_free(a)
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
if (allocated(a%nerwp)) deallocate(a%nerwp)
a%nnerws = 0
call a%psb_d_csr_sparse_mat%free()
return
end subroutine d_ecsr_free
! == ===================================
!
!

@ -79,12 +79,14 @@
module psb_d_mat_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat
use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat,&
& psb_d_ecsr_sparse_mat
use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat, psb_ld_csc_sparse_mat
type :: psb_dspmat_type
class(psb_d_base_sparse_mat), allocatable :: a
class(psb_d_base_sparse_mat), allocatable :: ad, and
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_ld_coo_sparse_mat), allocatable :: rmta
@ -202,6 +204,7 @@ module psb_d_mat_mod
procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_d_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_d_split_nd
procedure, pass(a) :: clone => psb_dspmat_clone
procedure, pass(a) :: move_alloc => psb_dspmat_type_move
!
@ -841,6 +844,18 @@ module psb_d_mat_mod
!
!
interface
subroutine psb_d_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_d_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_d_split_nd
end interface
!
! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target
@ -860,7 +875,6 @@ module psb_d_mat_mod
end subroutine psb_d_cscnv
end interface
interface
subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat
@ -872,7 +886,6 @@ module psb_d_mat_mod
end subroutine psb_d_cscnv_ip
end interface
interface
subroutine psb_d_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat

@ -102,6 +102,9 @@ module psb_d_vect_mod
procedure, pass(z) :: axpby_v2 => d_vect_axpby_v2
procedure, pass(z) :: axpby_a2 => d_vect_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => d_vect_abgdxyz
procedure, pass(z) :: xyzw => d_vect_xyzw
procedure, pass(y) :: mlt_v => d_vect_mlt_v
procedure, pass(y) :: mlt_a => d_vect_mlt_a
procedure, pass(z) :: mlt_a_2 => d_vect_mlt_a_2
@ -778,6 +781,38 @@ contains
end subroutine d_vect_axpby_a2
subroutine d_vect_abgdxyz(m,alpha,beta,gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_vect_type), intent(inout) :: y
class(psb_d_vect_type), intent(inout) :: z
real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (allocated(z%v)) &
call z%v%abgdxyz(m,alpha,beta,gamma,delta,x%v,y%v,info)
end subroutine d_vect_abgdxyz
subroutine d_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_vect_type), intent(inout) :: y
class(psb_d_vect_type), intent(inout) :: z
class(psb_d_vect_type), intent(inout) :: w
real(psb_dpk_), intent (in) :: a, b, c, d, e, f
integer(psb_ipk_), intent(out) :: info
if (allocated(w%v)) &
call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info)
end subroutine d_vect_xyzw
subroutine d_vect_mlt_v(x, y, info)
use psi_serial_mod
implicit none

@ -155,6 +155,9 @@ module psb_s_base_vect_mod
procedure, pass(z) :: axpby_v2 => s_base_axpby_v2
procedure, pass(z) :: axpby_a2 => s_base_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => s_base_abgdxyz
procedure, pass(w) :: xyzw => s_base_xyzw
!
! Vector by vector multiplication. Need all variants
! to handle multiple requirements from preconditioners
@ -1025,7 +1028,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine s_base_axpby_v(m,alpha, x, beta, y, info)
@ -1054,7 +1057,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be returned
!! \param info return code
@ -1085,7 +1088,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x(:) The array to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine s_base_axpby_a(m,alpha, x, beta, y, info)
@ -1133,6 +1136,64 @@ contains
end subroutine s_base_axpby_a2
!
! ABGDXYZ is invoked via Z, hence the structure below.
!
!
!> Function base_abgdxyz
!! \memberof psb_s_base_vect_type
!! \brief ABGDXYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param beta scalar beta
!! \param gamma scalar gamma
!! \param delta scalar delta
!! \param x The class(base_vect) to be added
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be added
!! \param info return code
!!
subroutine s_base_abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_s_base_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(inout) :: y
class(psb_s_base_vect_type), intent(inout) :: z
real(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(alpha/=szero)) call x%sync()
if (y%is_dev().and.(beta/=szero)) call y%sync()
if (z%is_dev().and.(delta/=szero)) call z%sync()
call psi_abgdxyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info)
call y%set_host()
call z%set_host()
end subroutine s_base_abgdxyz
subroutine s_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_s_base_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(inout) :: y
class(psb_s_base_vect_type), intent(inout) :: z
class(psb_s_base_vect_type), intent(inout) :: w
real(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(a/=szero)) call x%sync()
if (y%is_dev().and.(b/=szero)) call y%sync()
if (z%is_dev().and.(d/=szero)) call z%sync()
if (w%is_dev().and.(f/=szero)) call w%sync()
call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info)
call y%set_host()
call z%set_host()
call w%set_host()
end subroutine s_base_xyzw
!
! Multiple variants of two operations:

@ -579,6 +579,110 @@ module psb_s_csr_mat_mod
end subroutine psb_s_csr_scals
end interface
type, extends(psb_s_csr_sparse_mat) :: psb_s_ecsr_sparse_mat
!> Number of non-empty rows
integer(psb_ipk_) :: nnerws
!> Indices of non-empty rows
integer(psb_ipk_), allocatable :: nerwp(:)
contains
procedure, nopass :: get_fmt => s_ecsr_get_fmt
! procedure, pass(a) :: csmm => psb_s_ecsr_csmm
procedure, pass(a) :: csmv => psb_s_ecsr_csmv
procedure, pass(a) :: cp_from_coo => psb_s_cp_ecsr_from_coo
procedure, pass(a) :: cp_from_fmt => psb_s_cp_ecsr_from_fmt
procedure, pass(a) :: mv_from_coo => psb_s_mv_ecsr_from_coo
procedure, pass(a) :: mv_from_fmt => psb_s_mv_ecsr_from_fmt
procedure, pass(a) :: cmp_nerwp => psb_s_ecsr_cmp_nerwp
procedure, pass(a) :: free => s_ecsr_free
procedure, pass(a) :: mold => psb_s_ecsr_mold
end type psb_s_ecsr_sparse_mat
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_csmv
interface
subroutine psb_s_ecsr_csmv(alpha,a,x,beta,y,info,trans)
import
class(psb_s_ecsr_sparse_mat), intent(in) :: a
real(psb_spk_), intent(in) :: alpha, beta, x(:)
real(psb_spk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_s_ecsr_csmv
end interface
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo
interface
subroutine psb_s_ecsr_cmp_nerwp(a,info)
import
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_ecsr_cmp_nerwp
end interface
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo
interface
subroutine psb_s_cp_ecsr_from_coo(a,b,info)
import
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_cp_ecsr_from_coo
end interface
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt
interface
subroutine psb_s_cp_ecsr_from_fmt(a,b,info)
import
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_cp_ecsr_from_fmt
end interface
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo
interface
subroutine psb_s_mv_ecsr_from_coo(a,b,info)
import
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_mv_ecsr_from_coo
end interface
!> \memberof psb_s_ecsr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt
interface
subroutine psb_s_mv_ecsr_from_fmt(a,b,info)
import
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_mv_ecsr_from_fmt
end interface
!> \memberof psb_s_ecsr_sparse_mat
!| \see psb_base_mat_mod::psb_base_mold
interface
subroutine psb_s_ecsr_mold(a,b,info)
import
class(psb_s_ecsr_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_ecsr_mold
end interface
!> \namespace psb_base_mod \class psb_ls_csr_sparse_mat
!! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat
!!
@ -1178,6 +1282,26 @@ contains
function s_ecsr_get_fmt() result(res)
implicit none
character(len=5) :: res
res = 'ECSR'
end function s_ecsr_get_fmt
subroutine s_ecsr_free(a)
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
if (allocated(a%nerwp)) deallocate(a%nerwp)
a%nnerws = 0
call a%psb_s_csr_sparse_mat%free()
return
end subroutine s_ecsr_free
! == ===================================
!
!

@ -79,12 +79,14 @@
module psb_s_mat_mod
use psb_s_base_mat_mod
use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat
use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat,&
& psb_s_ecsr_sparse_mat
use psb_s_csc_mat_mod, only : psb_s_csc_sparse_mat, psb_ls_csc_sparse_mat
type :: psb_sspmat_type
class(psb_s_base_sparse_mat), allocatable :: a
class(psb_s_base_sparse_mat), allocatable :: ad, and
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_ls_coo_sparse_mat), allocatable :: rmta
@ -202,6 +204,7 @@ module psb_s_mat_mod
procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_s_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_s_split_nd
procedure, pass(a) :: clone => psb_sspmat_clone
procedure, pass(a) :: move_alloc => psb_sspmat_type_move
!
@ -840,6 +843,18 @@ module psb_s_mat_mod
!
!
interface
subroutine psb_s_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_s_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_s_split_nd
end interface
!
! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target
@ -859,7 +874,6 @@ module psb_s_mat_mod
end subroutine psb_s_cscnv
end interface
interface
subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
@ -871,7 +885,6 @@ module psb_s_mat_mod
end subroutine psb_s_cscnv_ip
end interface
interface
subroutine psb_s_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat

@ -102,6 +102,9 @@ module psb_s_vect_mod
procedure, pass(z) :: axpby_v2 => s_vect_axpby_v2
procedure, pass(z) :: axpby_a2 => s_vect_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => s_vect_abgdxyz
procedure, pass(z) :: xyzw => s_vect_xyzw
procedure, pass(y) :: mlt_v => s_vect_mlt_v
procedure, pass(y) :: mlt_a => s_vect_mlt_a
procedure, pass(z) :: mlt_a_2 => s_vect_mlt_a_2
@ -778,6 +781,38 @@ contains
end subroutine s_vect_axpby_a2
subroutine s_vect_abgdxyz(m,alpha,beta,gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_vect_type), intent(inout) :: y
class(psb_s_vect_type), intent(inout) :: z
real(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (allocated(z%v)) &
call z%v%abgdxyz(m,alpha,beta,gamma,delta,x%v,y%v,info)
end subroutine s_vect_abgdxyz
subroutine s_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_vect_type), intent(inout) :: y
class(psb_s_vect_type), intent(inout) :: z
class(psb_s_vect_type), intent(inout) :: w
real(psb_spk_), intent (in) :: a, b, c, d, e, f
integer(psb_ipk_), intent(out) :: info
if (allocated(w%v)) &
call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info)
end subroutine s_vect_xyzw
subroutine s_vect_mlt_v(x, y, info)
use psi_serial_mod
implicit none

@ -36,9 +36,7 @@ module psb_serial_mod
use psb_string_mod
use psb_sort_mod
use psi_serial_mod, &
& psb_gth => psi_gth,&
& psb_sct => psi_sct
use psi_serial_mod
use psb_s_serial_mod
use psb_d_serial_mod

@ -155,6 +155,9 @@ module psb_z_base_vect_mod
procedure, pass(z) :: axpby_v2 => z_base_axpby_v2
procedure, pass(z) :: axpby_a2 => z_base_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => z_base_abgdxyz
procedure, pass(w) :: xyzw => z_base_xyzw
!
! Vector by vector multiplication. Need all variants
! to handle multiple requirements from preconditioners
@ -1018,7 +1021,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine z_base_axpby_v(m,alpha, x, beta, y, info)
@ -1047,7 +1050,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x The class(base_vect) to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be returned
!! \param info return code
@ -1078,7 +1081,7 @@ contains
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param x(:) The array to be added
!! \param beta scalar alpha
!! \param beta scalar beta
!! \param info return code
!!
subroutine z_base_axpby_a(m,alpha, x, beta, y, info)
@ -1126,6 +1129,64 @@ contains
end subroutine z_base_axpby_a2
!
! ABGDXYZ is invoked via Z, hence the structure below.
!
!
!> Function base_abgdxyz
!! \memberof psb_z_base_vect_type
!! \brief ABGDXYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta
!! \param m Number of entries to be considered
!! \param alpha scalar alpha
!! \param beta scalar beta
!! \param gamma scalar gamma
!! \param delta scalar delta
!! \param x The class(base_vect) to be added
!! \param y The class(base_vect) to be added
!! \param z The class(base_vect) to be added
!! \param info return code
!!
subroutine z_base_abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(alpha/=zzero)) call x%sync()
if (y%is_dev().and.(beta/=zzero)) call y%sync()
if (z%is_dev().and.(delta/=zzero)) call z%sync()
call psi_abgdxyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info)
call y%set_host()
call z%set_host()
end subroutine z_base_abgdxyz
subroutine z_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
class(psb_z_base_vect_type), intent(inout) :: w
complex(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
if (x%is_dev().and.(a/=zzero)) call x%sync()
if (y%is_dev().and.(b/=zzero)) call y%sync()
if (z%is_dev().and.(d/=zzero)) call z%sync()
if (w%is_dev().and.(f/=zzero)) call w%sync()
call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info)
call y%set_host()
call z%set_host()
call w%set_host()
end subroutine z_base_xyzw
!
! Multiple variants of two operations:

@ -579,6 +579,110 @@ module psb_z_csr_mat_mod
end subroutine psb_z_csr_scals
end interface
type, extends(psb_z_csr_sparse_mat) :: psb_z_ecsr_sparse_mat
!> Number of non-empty rows
integer(psb_ipk_) :: nnerws
!> Indices of non-empty rows
integer(psb_ipk_), allocatable :: nerwp(:)
contains
procedure, nopass :: get_fmt => z_ecsr_get_fmt
! procedure, pass(a) :: csmm => psb_z_ecsr_csmm
procedure, pass(a) :: csmv => psb_z_ecsr_csmv
procedure, pass(a) :: cp_from_coo => psb_z_cp_ecsr_from_coo
procedure, pass(a) :: cp_from_fmt => psb_z_cp_ecsr_from_fmt
procedure, pass(a) :: mv_from_coo => psb_z_mv_ecsr_from_coo
procedure, pass(a) :: mv_from_fmt => psb_z_mv_ecsr_from_fmt
procedure, pass(a) :: cmp_nerwp => psb_z_ecsr_cmp_nerwp
procedure, pass(a) :: free => z_ecsr_free
procedure, pass(a) :: mold => psb_z_ecsr_mold
end type psb_z_ecsr_sparse_mat
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_csmv
interface
subroutine psb_z_ecsr_csmv(alpha,a,x,beta,y,info,trans)
import
class(psb_z_ecsr_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:)
complex(psb_dpk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_z_ecsr_csmv
end interface
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo
interface
subroutine psb_z_ecsr_cmp_nerwp(a,info)
import
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_ecsr_cmp_nerwp
end interface
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo
interface
subroutine psb_z_cp_ecsr_from_coo(a,b,info)
import
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_cp_ecsr_from_coo
end interface
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt
interface
subroutine psb_z_cp_ecsr_from_fmt(a,b,info)
import
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_cp_ecsr_from_fmt
end interface
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo
interface
subroutine psb_z_mv_ecsr_from_coo(a,b,info)
import
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_mv_ecsr_from_coo
end interface
!> \memberof psb_z_ecsr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt
interface
subroutine psb_z_mv_ecsr_from_fmt(a,b,info)
import
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_mv_ecsr_from_fmt
end interface
!> \memberof psb_z_ecsr_sparse_mat
!| \see psb_base_mat_mod::psb_base_mold
interface
subroutine psb_z_ecsr_mold(a,b,info)
import
class(psb_z_ecsr_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_ecsr_mold
end interface
!> \namespace psb_base_mod \class psb_lz_csr_sparse_mat
!! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat
!!
@ -1178,6 +1282,26 @@ contains
function z_ecsr_get_fmt() result(res)
implicit none
character(len=5) :: res
res = 'ECSR'
end function z_ecsr_get_fmt
subroutine z_ecsr_free(a)
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
if (allocated(a%nerwp)) deallocate(a%nerwp)
a%nnerws = 0
call a%psb_z_csr_sparse_mat%free()
return
end subroutine z_ecsr_free
! == ===================================
!
!

@ -79,12 +79,14 @@
module psb_z_mat_mod
use psb_z_base_mat_mod
use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat, psb_lz_csr_sparse_mat
use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat, psb_lz_csr_sparse_mat,&
& psb_z_ecsr_sparse_mat
use psb_z_csc_mat_mod, only : psb_z_csc_sparse_mat, psb_lz_csc_sparse_mat
type :: psb_zspmat_type
class(psb_z_base_sparse_mat), allocatable :: a
class(psb_z_base_sparse_mat), allocatable :: ad, and
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_lz_coo_sparse_mat), allocatable :: rmta
@ -202,6 +204,7 @@ module psb_z_mat_mod
procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_z_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_z_split_nd
procedure, pass(a) :: clone => psb_zspmat_clone
procedure, pass(a) :: move_alloc => psb_zspmat_type_move
!
@ -840,6 +843,18 @@ module psb_z_mat_mod
!
!
interface
subroutine psb_z_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_z_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_z_split_nd
end interface
!
! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target
@ -859,7 +874,6 @@ module psb_z_mat_mod
end subroutine psb_z_cscnv
end interface
interface
subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat
@ -871,7 +885,6 @@ module psb_z_mat_mod
end subroutine psb_z_cscnv_ip
end interface
interface
subroutine psb_z_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat

@ -102,6 +102,9 @@ module psb_z_vect_mod
procedure, pass(z) :: axpby_v2 => z_vect_axpby_v2
procedure, pass(z) :: axpby_a2 => z_vect_axpby_a2
generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2
procedure, pass(z) :: abgdxyz => z_vect_abgdxyz
procedure, pass(z) :: xyzw => z_vect_xyzw
procedure, pass(y) :: mlt_v => z_vect_mlt_v
procedure, pass(y) :: mlt_a => z_vect_mlt_a
procedure, pass(z) :: mlt_a_2 => z_vect_mlt_a_2
@ -771,6 +774,38 @@ contains
end subroutine z_vect_axpby_a2
subroutine z_vect_abgdxyz(m,alpha,beta,gamma,delta,x, y, z, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_vect_type), intent(inout) :: y
class(psb_z_vect_type), intent(inout) :: z
complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
if (allocated(z%v)) &
call z%v%abgdxyz(m,alpha,beta,gamma,delta,x%v,y%v,info)
end subroutine z_vect_abgdxyz
subroutine z_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_vect_type), intent(inout) :: y
class(psb_z_vect_type), intent(inout) :: z
class(psb_z_vect_type), intent(inout) :: w
complex(psb_dpk_), intent (in) :: a, b, c, d, e, f
integer(psb_ipk_), intent(out) :: info
if (allocated(w%v)) &
call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info)
end subroutine z_vect_xyzw
subroutine z_vect_mlt_v(x, y, info)
use psi_serial_mod
implicit none

@ -250,7 +250,7 @@ Module psb_c_tools_mod
end interface
interface psb_spasb
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
import
implicit none
type(psb_cspmat_type), intent (inout) :: a
@ -259,6 +259,7 @@ Module psb_c_tools_mod
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
end subroutine psb_cspasb
end interface

@ -276,7 +276,7 @@ Module psb_d_tools_mod
end interface
interface psb_spasb
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
import
implicit none
type(psb_dspmat_type), intent (inout) :: a
@ -285,6 +285,7 @@ Module psb_d_tools_mod
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
end subroutine psb_dspasb
end interface

@ -250,7 +250,7 @@ Module psb_s_tools_mod
end interface
interface psb_spasb
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
import
implicit none
type(psb_sspmat_type), intent (inout) :: a
@ -259,6 +259,7 @@ Module psb_s_tools_mod
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
end subroutine psb_sspasb
end interface

@ -250,7 +250,7 @@ Module psb_z_tools_mod
end interface
interface psb_spasb
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
import
implicit none
type(psb_zspmat_type), intent (inout) :: a
@ -259,6 +259,7 @@ Module psb_z_tools_mod
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
end subroutine psb_zspasb
end interface

@ -741,3 +741,86 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_caddconst_vect
subroutine psb_cabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
use psb_base_mod, psb_protect_name => psb_cabgdxyz_vect
implicit none
type(psb_c_vect_type), intent (inout) :: x
type(psb_c_vect_type), intent (inout) :: y
type(psb_c_vect_type), intent (inout) :: z
complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iiy, jjy, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
character(len=20) :: name, ch_err
name='psb_c_addconst_vect'
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
ctxt=desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -ione) 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
if (.not.allocated(y%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(z%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = ione
iy = ione
m = desc_a%get_global_rows()
nr = desc_a%get_local_rows()
! check vector correctness
call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(desc_a%get_local_rows() > 0) then
call z%abgdxyz(nr,alpha,beta,gamma,delta,x,y,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_cabgdxyz_vect

@ -83,6 +83,9 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_cspmv'
info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -179,12 +195,44 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then
! Matrix is not transposed
if (allocated(a%ad)) then
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,cone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_

@ -418,8 +418,8 @@ function psb_damax_multivect(x, desc_a, info, global) result(res)
jx = 1
m = desc_a%get_global_rows()
call psb_chkvect(m,x%get_ncols(),x%get_nrows(),ix,jx,desc_a,info,iix,jjx)
n = x%get_ncols()
call psb_chkvect(m,n,x%get_nrows(),ix,jx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'

@ -159,7 +159,7 @@ subroutine psb_daxpby_multivect(alpha, x, beta, y, desc_a, info)
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, iiy, jjy
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n
character(len=20) :: name, ch_err
name='psb_dgeaxpby'
@ -193,16 +193,17 @@ subroutine psb_daxpby_multivect(alpha, x, beta, y, desc_a, info)
ijy = ione
m = desc_a%get_global_rows()
n = x%get_ncols()
! check vector correctness
call psb_chkvect(m,x%get_ncols(),x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
call psb_chkvect(m,n,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,y%get_ncols(),y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
n = y%get_ncols()
call psb_chkvect(m,n,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
@ -257,7 +258,7 @@ subroutine psb_daxpby_multivect_a(alpha, x, beta, y, desc_a, info)
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iiy, jjy
integer(psb_lpk_) :: iy, ijy, m
integer(psb_lpk_) :: iy, ijy, m, n
character(len=20) :: name, ch_err
name='psb_dgeaxpby'
@ -283,8 +284,8 @@ subroutine psb_daxpby_multivect_a(alpha, x, beta, y, desc_a, info)
ijy = ione
m = desc_a%get_global_rows()
call psb_chkvect(m,y%get_ncols(),y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
n = y%get_ncols()
call psb_chkvect(m,n,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
@ -921,3 +922,86 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_daddconst_vect
subroutine psb_dabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
use psb_base_mod, psb_protect_name => psb_dabgdxyz_vect
implicit none
type(psb_d_vect_type), intent (inout) :: x
type(psb_d_vect_type), intent (inout) :: y
type(psb_d_vect_type), intent (inout) :: z
real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iiy, jjy, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
character(len=20) :: name, ch_err
name='psb_d_addconst_vect'
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
ctxt=desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -ione) 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
if (.not.allocated(y%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(z%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = ione
iy = ione
m = desc_a%get_global_rows()
nr = desc_a%get_local_rows()
! check vector correctness
call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(desc_a%get_local_rows() > 0) then
call z%abgdxyz(nr,alpha,beta,gamma,delta,x,y,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_dabgdxyz_vect

@ -194,7 +194,7 @@ function psb_ddot_multivect(x, y, desc_a,info,global) result(res)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, idx, ndm,&
& err_act, iix, jjx, iiy, jjy, i, j, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n
logical :: global_
character(len=20) :: name, ch_err
@ -236,11 +236,12 @@ function psb_ddot_multivect(x, y, desc_a,info,global) result(res)
ijy = ione
m = desc_a%get_global_rows()
n = x%get_ncols()
! check vector correctness
call psb_chkvect(m,x%get_ncols(),x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
call psb_chkvect(m,n,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
n = y%get_ncols()
if (info == psb_success_) &
& call psb_chkvect(m,y%get_ncols(),y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
& call psb_chkvect(m,n,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'

@ -402,7 +402,7 @@ function psb_dnrm2_multivect(x, desc_a, info, global) result(res)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, idx, i, j, iix, jjx, ldx, ndm
real(psb_dpk_) :: dd
integer(psb_lpk_) :: ix, jx, m
integer(psb_lpk_) :: ix, jx, m, n
logical :: global_
character(len=20) :: name, ch_err
@ -438,9 +438,9 @@ function psb_dnrm2_multivect(x, desc_a, info, global) result(res)
jx = 1
m = desc_a%get_global_rows()
n = x%get_ncols()
ldx = x%get_nrows()
call psb_chkvect(m,x%get_ncols(),ldx,ix,jx,desc_a,info,iix,jjx)
call psb_chkvect(m,n,ldx,ix,jx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'

@ -70,7 +70,7 @@ function psb_dprod_multivect(x,y,desc_a,info,trans,global) result(res)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, idx, ndm,&
& err_act, iix, jjx, iiy, jjy, i, j, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n
logical :: global_, trans_
character(len=20) :: name, ch_err
@ -118,11 +118,13 @@ function psb_dprod_multivect(x,y,desc_a,info,trans,global) result(res)
ijy = ione
m = desc_a%get_global_rows()
n = x%get_ncols()
! check vector correctness
call psb_chkvect(m,x%get_ncols(),x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
call psb_chkvect(m,n,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
n = y%get_ncols()
if (info == psb_success_) &
& call psb_chkvect(m,y%get_ncols(),y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
& call psb_chkvect(m,n,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -207,7 +209,7 @@ function psb_dprod_multivect_a(x,y,desc_a,info,trans,global) result(res)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, idx, ndm,&
& err_act, iix, jjx, iiy, jjy, i, j, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n
logical :: global_, trans_
character(len=20) :: name, ch_err
@ -249,7 +251,8 @@ function psb_dprod_multivect_a(x,y,desc_a,info,trans,global) result(res)
m = desc_a%get_global_rows()
! check vector correctness
call psb_chkvect(m,x%get_ncols(),x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
n = x%get_ncols()
call psb_chkvect(m,n,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -332,7 +335,7 @@ function psb_dprod_m(x,y,desc_a,info,trans,global) result(res)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, idx, ndm,&
& err_act, iix, jjx, iiy, jjy, i, j, nr, x_n, y_n, lda, ldb
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n
logical :: global_, trans_
character(len=20) :: name, ch_err
@ -369,7 +372,8 @@ function psb_dprod_m(x,y,desc_a,info,trans,global) result(res)
m = desc_a%get_global_rows()
! check vector correctness
call psb_chkvect(m,size(x,2),size(x,1),ix,ijx,desc_a,info,iix,jjx)
n = size(x,2)
call psb_chkvect(m,n,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'

@ -83,6 +83,9 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_dspmv'
info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -179,12 +195,44 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then
! Matrix is not transposed
if (allocated(a%ad)) then
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,done,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_

@ -741,3 +741,86 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_saddconst_vect
subroutine psb_sabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
use psb_base_mod, psb_protect_name => psb_sabgdxyz_vect
implicit none
type(psb_s_vect_type), intent (inout) :: x
type(psb_s_vect_type), intent (inout) :: y
type(psb_s_vect_type), intent (inout) :: z
real(psb_spk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iiy, jjy, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
character(len=20) :: name, ch_err
name='psb_s_addconst_vect'
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
ctxt=desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -ione) 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
if (.not.allocated(y%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(z%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = ione
iy = ione
m = desc_a%get_global_rows()
nr = desc_a%get_local_rows()
! check vector correctness
call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(desc_a%get_local_rows() > 0) then
call z%abgdxyz(nr,alpha,beta,gamma,delta,x,y,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_sabgdxyz_vect

@ -83,6 +83,9 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_sspmv'
info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -179,12 +195,44 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then
! Matrix is not transposed
if (allocated(a%ad)) then
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,sone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_

@ -741,3 +741,86 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info)
return
end subroutine psb_zaddconst_vect
subroutine psb_zabgdxyz_vect(alpha, beta, gamma, delta, x, y, z,&
& desc_a, info)
use psb_base_mod, psb_protect_name => psb_zabgdxyz_vect
implicit none
type(psb_z_vect_type), intent (inout) :: x
type(psb_z_vect_type), intent (inout) :: y
type(psb_z_vect_type), intent (inout) :: z
complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
type(psb_desc_type), intent (in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iiy, jjy, nr
integer(psb_lpk_) :: ix, ijx, iy, ijy, m
character(len=20) :: name, ch_err
name='psb_z_addconst_vect'
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
ctxt=desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -ione) 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
if (.not.allocated(y%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(z%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
ix = ione
iy = ione
m = desc_a%get_global_rows()
nr = desc_a%get_local_rows()
! check vector correctness
call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(desc_a%get_local_rows() > 0) then
call z%abgdxyz(nr,alpha,beta,gamma,delta,x,y,info)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psb_zabgdxyz_vect

@ -83,6 +83,9 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_zspmv'
info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -179,12 +195,44 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then
! Matrix is not transposed
if (allocated(a%ad)) then
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,zone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_

@ -4312,6 +4312,266 @@ contains
end subroutine psb_ccsrspspmm
#endif
subroutine psb_c_ecsr_mold(a,b,info)
use psb_c_csr_mat_mod, psb_protect_name => psb_c_ecsr_mold
use psb_error_mod
implicit none
class(psb_c_ecsr_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='ecsr_mold'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = 0
if (allocated(b)) then
call b%free()
deallocate(b,stat=info)
end if
if (info == 0) allocate(psb_c_ecsr_sparse_mat :: b, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
goto 9999
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_ecsr_mold
subroutine psb_c_ecsr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psb_string_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_ecsr_csmv
implicit none
class(psb_c_ecsr_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta, x(:)
complex(psb_spk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
character :: trans_
integer(psb_ipk_) :: m, n
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_csmv'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
trans_ = 'N'
end if
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
n = a%get_ncols()
m = a%get_nrows()
end if
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if ((beta == cone).and.&
& .not.(tra.or.ctra.or.(a%is_triangle()).or.(a%is_unit()))) then
call psb_c_ecsr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%nnerws,a%nerwp,x,y)
else
call a%psb_c_csr_sparse_mat%csmv(alpha,x,beta,y,info,trans)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
contains
subroutine psb_c_ecsr_csmv_inner(m,n,alpha,irp,ja,val,&
& nnerws,nerwp,x,y)
integer(psb_ipk_), intent(in) :: m,n,nnerws,irp(*),ja(*),nerwp(*)
complex(psb_spk_), intent(in) :: alpha, x(*),val(*)
complex(psb_spk_), intent(inout) :: y(*)
integer(psb_ipk_) :: i,j,ir
complex(psb_spk_) :: acc
if (alpha == czero) return
if (alpha == cone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = czero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -cone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = czero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) -acc
end do
else
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = czero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
end subroutine psb_c_ecsr_csmv_inner
end subroutine psb_c_ecsr_csmv
subroutine psb_c_ecsr_cmp_nerwp(a,info)
use psb_const_mod
use psb_realloc_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_ecsr_cmp_nerwp
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nnerws, i, nr, nzr
info = psb_success_
nr = a%get_nrows()
call psb_realloc(nr,a%nerwp,info)
nnerws = 0
do i=1, nr
nzr = a%irp(i+1)-a%irp(i)
if (nzr>0) then
nnerws = nnerws + 1
a%nerwp(nnerws) = i
end if
end do
call psb_realloc(nnerws,a%nerwp,info)
a%nnerws = nnerws
end subroutine psb_c_ecsr_cmp_nerwp
subroutine psb_c_cp_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_ecsr_from_coo
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_c_csr_sparse_mat%cp_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_c_cp_ecsr_from_coo
subroutine psb_c_mv_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_error_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_ecsr_from_coo
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_c_csr_sparse_mat%mv_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_c_mv_ecsr_from_coo
subroutine psb_c_mv_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_ecsr_from_fmt
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_c_csr_sparse_mat%mv_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_c_mv_ecsr_from_fmt
subroutine psb_c_cp_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_c_base_mat_mod
use psb_realloc_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_ecsr_from_fmt
implicit none
class(psb_c_ecsr_sparse_mat), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_c_csr_sparse_mat%cp_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_c_cp_ecsr_from_fmt
!
!
! lc version

@ -1213,6 +1213,56 @@ subroutine psb_c_b_csclip(a,b,info,&
end subroutine psb_c_b_csclip
subroutine psb_c_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_c_mat_mod, psb_protect_name => psb_c_split_nd
implicit none
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_c_base_sparse_mat), intent(in), optional :: mold
type(psb_c_coo_sparse_mat) :: acoo
type(psb_c_csr_sparse_mat), allocatable :: aclip
type(psb_c_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_split_nd
subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
@ -1246,6 +1296,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1294,6 +1345,16 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
else
call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if
call b%trim()
call b%set_asb()
call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_c_base_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_c_cscnv
subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
@ -1318,7 +1451,6 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip'
@ -1345,6 +1477,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1377,14 +1510,22 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
call move_alloc(altmp,a%a)
else
call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%trim()
call a%set_asb()
call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_c_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_c_cscnv_ip

@ -4312,6 +4312,266 @@ contains
end subroutine psb_dcsrspspmm
#endif
subroutine psb_d_ecsr_mold(a,b,info)
use psb_d_csr_mat_mod, psb_protect_name => psb_d_ecsr_mold
use psb_error_mod
implicit none
class(psb_d_ecsr_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='ecsr_mold'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = 0
if (allocated(b)) then
call b%free()
deallocate(b,stat=info)
end if
if (info == 0) allocate(psb_d_ecsr_sparse_mat :: b, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
goto 9999
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_ecsr_mold
subroutine psb_d_ecsr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_ecsr_csmv
implicit none
class(psb_d_ecsr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
character :: trans_
integer(psb_ipk_) :: m, n
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csmv'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
trans_ = 'N'
end if
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
n = a%get_ncols()
m = a%get_nrows()
end if
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if ((beta == done).and.&
& .not.(tra.or.ctra.or.(a%is_triangle()).or.(a%is_unit()))) then
call psb_d_ecsr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%nnerws,a%nerwp,x,y)
else
call a%psb_d_csr_sparse_mat%csmv(alpha,x,beta,y,info,trans)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
contains
subroutine psb_d_ecsr_csmv_inner(m,n,alpha,irp,ja,val,&
& nnerws,nerwp,x,y)
integer(psb_ipk_), intent(in) :: m,n,nnerws,irp(*),ja(*),nerwp(*)
real(psb_dpk_), intent(in) :: alpha, x(*),val(*)
real(psb_dpk_), intent(inout) :: y(*)
integer(psb_ipk_) :: i,j,ir
real(psb_dpk_) :: acc
if (alpha == dzero) return
if (alpha == done) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -done) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) -acc
end do
else
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
end subroutine psb_d_ecsr_csmv_inner
end subroutine psb_d_ecsr_csmv
subroutine psb_d_ecsr_cmp_nerwp(a,info)
use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_ecsr_cmp_nerwp
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nnerws, i, nr, nzr
info = psb_success_
nr = a%get_nrows()
call psb_realloc(nr,a%nerwp,info)
nnerws = 0
do i=1, nr
nzr = a%irp(i+1)-a%irp(i)
if (nzr>0) then
nnerws = nnerws + 1
a%nerwp(nnerws) = i
end if
end do
call psb_realloc(nnerws,a%nerwp,info)
a%nnerws = nnerws
end subroutine psb_d_ecsr_cmp_nerwp
subroutine psb_d_cp_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_ecsr_from_coo
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_d_csr_sparse_mat%cp_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_d_cp_ecsr_from_coo
subroutine psb_d_mv_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_error_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_ecsr_from_coo
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_d_csr_sparse_mat%mv_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_d_mv_ecsr_from_coo
subroutine psb_d_mv_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_ecsr_from_fmt
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_d_csr_sparse_mat%mv_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_d_mv_ecsr_from_fmt
subroutine psb_d_cp_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_d_base_mat_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_ecsr_from_fmt
implicit none
class(psb_d_ecsr_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_d_csr_sparse_mat%cp_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_d_cp_ecsr_from_fmt
!
!
! ld version

@ -1213,6 +1213,56 @@ subroutine psb_d_b_csclip(a,b,info,&
end subroutine psb_d_b_csclip
subroutine psb_d_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_d_mat_mod, psb_protect_name => psb_d_split_nd
implicit none
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_d_base_sparse_mat), intent(in), optional :: mold
type(psb_d_coo_sparse_mat) :: acoo
type(psb_d_csr_sparse_mat), allocatable :: aclip
type(psb_d_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_split_nd
subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
@ -1246,6 +1296,7 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1294,6 +1345,16 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
else
call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if
call b%trim()
call b%set_asb()
call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_d_base_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_d_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_d_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_d_cscnv
subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
@ -1318,7 +1451,6 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip'
@ -1345,6 +1477,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1377,14 +1510,22 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
call move_alloc(altmp,a%a)
else
call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%trim()
call a%set_asb()
call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_d_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_d_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_d_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_d_cscnv_ip

@ -4312,6 +4312,266 @@ contains
end subroutine psb_scsrspspmm
#endif
subroutine psb_s_ecsr_mold(a,b,info)
use psb_s_csr_mat_mod, psb_protect_name => psb_s_ecsr_mold
use psb_error_mod
implicit none
class(psb_s_ecsr_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='ecsr_mold'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = 0
if (allocated(b)) then
call b%free()
deallocate(b,stat=info)
end if
if (info == 0) allocate(psb_s_ecsr_sparse_mat :: b, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
goto 9999
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_ecsr_mold
subroutine psb_s_ecsr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psb_string_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_ecsr_csmv
implicit none
class(psb_s_ecsr_sparse_mat), intent(in) :: a
real(psb_spk_), intent(in) :: alpha, beta, x(:)
real(psb_spk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
character :: trans_
integer(psb_ipk_) :: m, n
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_csmv'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
trans_ = 'N'
end if
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
n = a%get_ncols()
m = a%get_nrows()
end if
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if ((beta == sone).and.&
& .not.(tra.or.ctra.or.(a%is_triangle()).or.(a%is_unit()))) then
call psb_s_ecsr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%nnerws,a%nerwp,x,y)
else
call a%psb_s_csr_sparse_mat%csmv(alpha,x,beta,y,info,trans)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
contains
subroutine psb_s_ecsr_csmv_inner(m,n,alpha,irp,ja,val,&
& nnerws,nerwp,x,y)
integer(psb_ipk_), intent(in) :: m,n,nnerws,irp(*),ja(*),nerwp(*)
real(psb_spk_), intent(in) :: alpha, x(*),val(*)
real(psb_spk_), intent(inout) :: y(*)
integer(psb_ipk_) :: i,j,ir
real(psb_spk_) :: acc
if (alpha == szero) return
if (alpha == sone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -sone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) -acc
end do
else
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
end subroutine psb_s_ecsr_csmv_inner
end subroutine psb_s_ecsr_csmv
subroutine psb_s_ecsr_cmp_nerwp(a,info)
use psb_const_mod
use psb_realloc_mod
use psb_s_base_mat_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_ecsr_cmp_nerwp
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nnerws, i, nr, nzr
info = psb_success_
nr = a%get_nrows()
call psb_realloc(nr,a%nerwp,info)
nnerws = 0
do i=1, nr
nzr = a%irp(i+1)-a%irp(i)
if (nzr>0) then
nnerws = nnerws + 1
a%nerwp(nnerws) = i
end if
end do
call psb_realloc(nnerws,a%nerwp,info)
a%nnerws = nnerws
end subroutine psb_s_ecsr_cmp_nerwp
subroutine psb_s_cp_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_s_base_mat_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_ecsr_from_coo
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_s_csr_sparse_mat%cp_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_s_cp_ecsr_from_coo
subroutine psb_s_mv_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_error_mod
use psb_s_base_mat_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_ecsr_from_coo
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_s_csr_sparse_mat%mv_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_s_mv_ecsr_from_coo
subroutine psb_s_mv_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_s_base_mat_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_ecsr_from_fmt
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_s_csr_sparse_mat%mv_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_s_mv_ecsr_from_fmt
subroutine psb_s_cp_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_s_base_mat_mod
use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_ecsr_from_fmt
implicit none
class(psb_s_ecsr_sparse_mat), intent(inout) :: a
class(psb_s_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_s_csr_sparse_mat%cp_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_s_cp_ecsr_from_fmt
!
!
! ls version

@ -1213,6 +1213,56 @@ subroutine psb_s_b_csclip(a,b,info,&
end subroutine psb_s_b_csclip
subroutine psb_s_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_s_mat_mod, psb_protect_name => psb_s_split_nd
implicit none
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_s_base_sparse_mat), intent(in), optional :: mold
type(psb_s_coo_sparse_mat) :: acoo
type(psb_s_csr_sparse_mat), allocatable :: aclip
type(psb_s_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_split_nd
subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
@ -1246,6 +1296,7 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1294,6 +1345,16 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
else
call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if
call b%trim()
call b%set_asb()
call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_s_cscnv
subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
@ -1318,7 +1451,6 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip'
@ -1345,6 +1477,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1377,14 +1510,22 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
call move_alloc(altmp,a%a)
else
call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%trim()
call a%set_asb()
call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_s_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_s_cscnv_ip

@ -4312,6 +4312,266 @@ contains
end subroutine psb_zcsrspspmm
#endif
subroutine psb_z_ecsr_mold(a,b,info)
use psb_z_csr_mat_mod, psb_protect_name => psb_z_ecsr_mold
use psb_error_mod
implicit none
class(psb_z_ecsr_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='ecsr_mold'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = 0
if (allocated(b)) then
call b%free()
deallocate(b,stat=info)
end if
if (info == 0) allocate(psb_z_ecsr_sparse_mat :: b, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
goto 9999
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_ecsr_mold
subroutine psb_z_ecsr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psb_string_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_ecsr_csmv
implicit none
class(psb_z_ecsr_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:)
complex(psb_dpk_), intent(inout) :: y(:)
integer(psb_ipk_), intent(out) :: info
character, optional, intent(in) :: trans
character :: trans_
integer(psb_ipk_) :: m, n
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_csmv'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
trans_ = 'N'
end if
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
n = a%get_ncols()
m = a%get_nrows()
end if
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if ((beta == zone).and.&
& .not.(tra.or.ctra.or.(a%is_triangle()).or.(a%is_unit()))) then
call psb_z_ecsr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%nnerws,a%nerwp,x,y)
else
call a%psb_z_csr_sparse_mat%csmv(alpha,x,beta,y,info,trans)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
contains
subroutine psb_z_ecsr_csmv_inner(m,n,alpha,irp,ja,val,&
& nnerws,nerwp,x,y)
integer(psb_ipk_), intent(in) :: m,n,nnerws,irp(*),ja(*),nerwp(*)
complex(psb_dpk_), intent(in) :: alpha, x(*),val(*)
complex(psb_dpk_), intent(inout) :: y(*)
integer(psb_ipk_) :: i,j,ir
complex(psb_dpk_) :: acc
if (alpha == zzero) return
if (alpha == zone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = zzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -zone) then
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = zzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) -acc
end do
else
!$omp parallel do private(ir,i,j,acc)
do ir=1,nnerws
i = nerwp(ir)
acc = zzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
end subroutine psb_z_ecsr_csmv_inner
end subroutine psb_z_ecsr_csmv
subroutine psb_z_ecsr_cmp_nerwp(a,info)
use psb_const_mod
use psb_realloc_mod
use psb_z_base_mat_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_ecsr_cmp_nerwp
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nnerws, i, nr, nzr
info = psb_success_
nr = a%get_nrows()
call psb_realloc(nr,a%nerwp,info)
nnerws = 0
do i=1, nr
nzr = a%irp(i+1)-a%irp(i)
if (nzr>0) then
nnerws = nnerws + 1
a%nerwp(nnerws) = i
end if
end do
call psb_realloc(nnerws,a%nerwp,info)
a%nnerws = nnerws
end subroutine psb_z_ecsr_cmp_nerwp
subroutine psb_z_cp_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_z_base_mat_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_ecsr_from_coo
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_coo_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_z_csr_sparse_mat%cp_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_z_cp_ecsr_from_coo
subroutine psb_z_mv_ecsr_from_coo(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_error_mod
use psb_z_base_mat_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_ecsr_from_coo
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_coo_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_z_csr_sparse_mat%mv_from_coo(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_z_mv_ecsr_from_coo
subroutine psb_z_mv_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_z_base_mat_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_ecsr_from_fmt
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_z_csr_sparse_mat%mv_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_z_mv_ecsr_from_fmt
subroutine psb_z_cp_ecsr_from_fmt(a,b,info)
use psb_const_mod
use psb_z_base_mat_mod
use psb_realloc_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_ecsr_from_fmt
implicit none
class(psb_z_ecsr_sparse_mat), intent(inout) :: a
class(psb_z_base_sparse_mat), intent(in) :: b
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call a%psb_z_csr_sparse_mat%cp_from_fmt(b,info)
if (info == psb_success_) call a%cmp_nerwp(info)
end subroutine psb_z_cp_ecsr_from_fmt
!
!
! lz version

@ -1213,6 +1213,56 @@ subroutine psb_z_b_csclip(a,b,info,&
end subroutine psb_z_b_csclip
subroutine psb_z_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_z_mat_mod, psb_protect_name => psb_z_split_nd
implicit none
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_z_base_sparse_mat), intent(in), optional :: mold
type(psb_z_coo_sparse_mat) :: acoo
type(psb_z_csr_sparse_mat), allocatable :: aclip
type(psb_z_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_split_nd
subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
@ -1246,6 +1296,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1294,6 +1345,16 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
else
call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if
call b%trim()
call b%set_asb()
call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_z_base_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_z_cscnv
subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
@ -1318,7 +1451,6 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip'
@ -1345,6 +1477,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
goto 9999
end if
if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
@ -1377,14 +1510,22 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
call move_alloc(altmp,a%a)
else
call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%trim()
call a%set_asb()
call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act)
return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_z_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_z_cscnv_ip

@ -1567,3 +1567,300 @@ subroutine caxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine caxpbyv2
subroutine psi_cabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_spk_), intent (in) :: x(:)
complex(psb_spk_), intent (inout) :: y(:)
complex(psb_spk_), intent (inout) :: z(:)
complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='cabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == czero) then
if (gamma == czero) then
if (alpha == czero) then
if (delta == czero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = czero
z(i) = czero
end do
else if (delta /= czero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = czero
z(i) = delta*z(i)
end do
end if
else if (alpha /= czero) then
if (delta == czero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = czero
end do
else if (delta /= czero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= czero) then
if (alpha == czero) then
if (delta == czero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = czero
z(i) = czero ! gamma*y(i)
end do
else if (delta /= czero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = czero
z(i) = delta*z(i)
end do
end if
else if (alpha /= czero) then
if (delta == czero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= czero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= czero) then
if (gamma == czero) then
if (alpha == czero) then
if (delta == czero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = czero
end do
else if (delta /= czero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= czero) then
if (delta == czero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = czero
end do
else if (delta /= czero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= czero) then
if (alpha == czero) then
if (delta == czero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= czero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= czero) then
if (delta == czero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= czero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_cabgdxyz
subroutine psi_cxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_spk_), intent (in) :: x(:)
complex(psb_spk_), intent (inout) :: y(:)
complex(psb_spk_), intent (inout) :: z(:)
complex(psb_spk_), intent (inout) :: w(:)
complex(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='cabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==czero).or.(b==czero).or. &
& (c==czero).or.(d==czero).or.&
& (e==czero).or.(f==czero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_cxyzw

@ -1567,3 +1567,300 @@ subroutine daxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine daxpbyv2
subroutine psi_dabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_dpk_), intent (in) :: x(:)
real(psb_dpk_), intent (inout) :: y(:)
real(psb_dpk_), intent (inout) :: z(:)
real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='dabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == dzero) then
if (gamma == dzero) then
if (alpha == dzero) then
if (delta == dzero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = dzero
z(i) = dzero
end do
else if (delta /= dzero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = dzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= dzero) then
if (delta == dzero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = dzero
end do
else if (delta /= dzero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= dzero) then
if (alpha == dzero) then
if (delta == dzero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = dzero
z(i) = dzero ! gamma*y(i)
end do
else if (delta /= dzero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = dzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= dzero) then
if (delta == dzero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= dzero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= dzero) then
if (gamma == dzero) then
if (alpha == dzero) then
if (delta == dzero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = dzero
end do
else if (delta /= dzero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= dzero) then
if (delta == dzero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = dzero
end do
else if (delta /= dzero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= dzero) then
if (alpha == dzero) then
if (delta == dzero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= dzero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= dzero) then
if (delta == dzero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= dzero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_dabgdxyz
subroutine psi_dxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_dpk_), intent (in) :: x(:)
real(psb_dpk_), intent (inout) :: y(:)
real(psb_dpk_), intent (inout) :: z(:)
real(psb_dpk_), intent (inout) :: w(:)
real(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='dabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==dzero).or.(b==dzero).or. &
& (c==dzero).or.(d==dzero).or.&
& (e==dzero).or.(f==dzero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_dxyzw

@ -1567,3 +1567,300 @@ subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine eaxpbyv2
subroutine psi_eabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_epk_), intent (in) :: x(:)
integer(psb_epk_), intent (inout) :: y(:)
integer(psb_epk_), intent (inout) :: z(:)
integer(psb_epk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='eabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == ezero) then
if (gamma == ezero) then
if (alpha == ezero) then
if (delta == ezero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = ezero
z(i) = ezero
end do
else if (delta /= ezero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = ezero
z(i) = delta*z(i)
end do
end if
else if (alpha /= ezero) then
if (delta == ezero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = ezero
end do
else if (delta /= ezero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= ezero) then
if (alpha == ezero) then
if (delta == ezero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = ezero
z(i) = ezero ! gamma*y(i)
end do
else if (delta /= ezero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = ezero
z(i) = delta*z(i)
end do
end if
else if (alpha /= ezero) then
if (delta == ezero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= ezero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= ezero) then
if (gamma == ezero) then
if (alpha == ezero) then
if (delta == ezero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = ezero
end do
else if (delta /= ezero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= ezero) then
if (delta == ezero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = ezero
end do
else if (delta /= ezero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= ezero) then
if (alpha == ezero) then
if (delta == ezero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= ezero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= ezero) then
if (delta == ezero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= ezero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_eabgdxyz
subroutine psi_exyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_epk_), intent (in) :: x(:)
integer(psb_epk_), intent (inout) :: y(:)
integer(psb_epk_), intent (inout) :: z(:)
integer(psb_epk_), intent (inout) :: w(:)
integer(psb_epk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='eabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==ezero).or.(b==ezero).or. &
& (c==ezero).or.(d==ezero).or.&
& (e==ezero).or.(f==ezero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_exyzw

@ -1567,3 +1567,300 @@ subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine i2axpbyv2
subroutine psi_i2abgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (inout) :: y(:)
integer(psb_i2pk_), intent (inout) :: z(:)
integer(psb_i2pk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='i2abgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == i2zero) then
if (gamma == i2zero) then
if (alpha == i2zero) then
if (delta == i2zero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = i2zero
z(i) = i2zero
end do
else if (delta /= i2zero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = i2zero
z(i) = delta*z(i)
end do
end if
else if (alpha /= i2zero) then
if (delta == i2zero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = i2zero
end do
else if (delta /= i2zero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= i2zero) then
if (alpha == i2zero) then
if (delta == i2zero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = i2zero
z(i) = i2zero ! gamma*y(i)
end do
else if (delta /= i2zero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = i2zero
z(i) = delta*z(i)
end do
end if
else if (alpha /= i2zero) then
if (delta == i2zero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= i2zero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= i2zero) then
if (gamma == i2zero) then
if (alpha == i2zero) then
if (delta == i2zero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = i2zero
end do
else if (delta /= i2zero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= i2zero) then
if (delta == i2zero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = i2zero
end do
else if (delta /= i2zero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= i2zero) then
if (alpha == i2zero) then
if (delta == i2zero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= i2zero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= i2zero) then
if (delta == i2zero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= i2zero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_i2abgdxyz
subroutine psi_i2xyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (inout) :: y(:)
integer(psb_i2pk_), intent (inout) :: z(:)
integer(psb_i2pk_), intent (inout) :: w(:)
integer(psb_i2pk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='i2abgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==i2zero).or.(b==i2zero).or. &
& (c==i2zero).or.(d==i2zero).or.&
& (e==i2zero).or.(f==i2zero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_i2xyzw

@ -1567,3 +1567,300 @@ subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine maxpbyv2
subroutine psi_mabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_mpk_), intent (in) :: x(:)
integer(psb_mpk_), intent (inout) :: y(:)
integer(psb_mpk_), intent (inout) :: z(:)
integer(psb_mpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='mabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == mzero) then
if (gamma == mzero) then
if (alpha == mzero) then
if (delta == mzero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = mzero
z(i) = mzero
end do
else if (delta /= mzero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = mzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= mzero) then
if (delta == mzero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = mzero
end do
else if (delta /= mzero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= mzero) then
if (alpha == mzero) then
if (delta == mzero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = mzero
z(i) = mzero ! gamma*y(i)
end do
else if (delta /= mzero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = mzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= mzero) then
if (delta == mzero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= mzero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= mzero) then
if (gamma == mzero) then
if (alpha == mzero) then
if (delta == mzero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = mzero
end do
else if (delta /= mzero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= mzero) then
if (delta == mzero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = mzero
end do
else if (delta /= mzero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= mzero) then
if (alpha == mzero) then
if (delta == mzero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= mzero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= mzero) then
if (delta == mzero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= mzero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_mabgdxyz
subroutine psi_mxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_mpk_), intent (in) :: x(:)
integer(psb_mpk_), intent (inout) :: y(:)
integer(psb_mpk_), intent (inout) :: z(:)
integer(psb_mpk_), intent (inout) :: w(:)
integer(psb_mpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='mabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==mzero).or.(b==mzero).or. &
& (c==mzero).or.(d==mzero).or.&
& (e==mzero).or.(f==mzero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_mxyzw

@ -1567,3 +1567,300 @@ subroutine saxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine saxpbyv2
subroutine psi_sabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_spk_), intent (in) :: x(:)
real(psb_spk_), intent (inout) :: y(:)
real(psb_spk_), intent (inout) :: z(:)
real(psb_spk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='sabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == szero) then
if (gamma == szero) then
if (alpha == szero) then
if (delta == szero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = szero
z(i) = szero
end do
else if (delta /= szero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = szero
z(i) = delta*z(i)
end do
end if
else if (alpha /= szero) then
if (delta == szero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = szero
end do
else if (delta /= szero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= szero) then
if (alpha == szero) then
if (delta == szero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = szero
z(i) = szero ! gamma*y(i)
end do
else if (delta /= szero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = szero
z(i) = delta*z(i)
end do
end if
else if (alpha /= szero) then
if (delta == szero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= szero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= szero) then
if (gamma == szero) then
if (alpha == szero) then
if (delta == szero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = szero
end do
else if (delta /= szero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= szero) then
if (delta == szero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = szero
end do
else if (delta /= szero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= szero) then
if (alpha == szero) then
if (delta == szero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= szero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= szero) then
if (delta == szero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= szero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_sabgdxyz
subroutine psi_sxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
real(psb_spk_), intent (in) :: x(:)
real(psb_spk_), intent (inout) :: y(:)
real(psb_spk_), intent (inout) :: z(:)
real(psb_spk_), intent (inout) :: w(:)
real(psb_spk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='sabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==szero).or.(b==szero).or. &
& (c==szero).or.(d==szero).or.&
& (e==szero).or.(f==szero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_sxyzw

@ -1567,3 +1567,300 @@ subroutine zaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info)
return
end subroutine zaxpbyv2
subroutine psi_zabgdxyz(m,alpha, beta, gamma,delta,x, y, z, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_dpk_), intent (in) :: x(:)
complex(psb_dpk_), intent (inout) :: y(:)
complex(psb_dpk_), intent (inout) :: z(:)
complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='zabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if (beta == zzero) then
if (gamma == zzero) then
if (alpha == zzero) then
if (delta == zzero) then
! a 0 b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = zzero
z(i) = zzero
end do
else if (delta /= zzero) then
! a 0 b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = zzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= zzero) then
if (delta == zzero) then
! a n b 0 g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = zzero
end do
else if (delta /= zzero) then
! a n b 0 g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= zzero) then
if (alpha == zzero) then
if (delta == zzero) then
! a 0 b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = zzero
z(i) = zzero ! gamma*y(i)
end do
else if (delta /= zzero) then
! a 0 b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = zzero
z(i) = delta*z(i)
end do
end if
else if (alpha /= zzero) then
if (delta == zzero) then
! a n b 0 g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)
end do
else if (delta /= zzero) then
! a n b 0 g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
else if (beta /= zzero) then
if (gamma == zzero) then
if (alpha == zzero) then
if (delta == zzero) then
! a 0 b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = zzero
end do
else if (delta /= zzero) then
! a 0 b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = delta*z(i)
end do
end if
else if (alpha /= zzero) then
if (delta == zzero) then
! a n b n g 0 d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = zzero
end do
else if (delta /= zzero) then
! a n b n g 0 d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = delta*z(i)
end do
end if
end if
else if (gamma /= zzero) then
if (alpha == zzero) then
if (delta == zzero) then
! a 0 b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= zzero) then
! a 0 b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
else if (alpha /= zzero) then
if (delta == zzero) then
! a n b n g n d 0
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)
end do
else if (delta /= zzero) then
! a n b n g n d n
!$omp parallel do private(i)
do i=1,m
y(i) = alpha*x(i)+beta*y(i)
z(i) = gamma*y(i)+delta*z(i)
end do
end if
end if
end if
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_zabgdxyz
subroutine psi_zxyzw(m,a,b,c,d,e,f,x, y, z,w, info)
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: m
complex(psb_dpk_), intent (in) :: x(:)
complex(psb_dpk_), intent (inout) :: y(:)
complex(psb_dpk_), intent (inout) :: z(:)
complex(psb_dpk_), intent (inout) :: w(:)
complex(psb_dpk_), intent (in) :: a,b,c,d,e,f
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: int_err(5)
character name*20
name='zabgdxyz'
info = psb_success_
if (m.lt.0) then
info=psb_err_iarg_neg_
int_err(1)=1
int_err(2)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(x).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=6
int_err(2)=1
int_err(3)=size(x)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(y).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=7
int_err(2)=1
int_err(3)=size(y)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
else if (size(z).lt.max(1,m)) then
info=psb_err_iarg_not_gtia_ii_
int_err(1)=8
int_err(2)=1
int_err(3)=size(z)
int_err(4)=m
call fcpsb_errpush(info,name,int_err)
goto 9999
endif
if ((a==zzero).or.(b==zzero).or. &
& (c==zzero).or.(d==zzero).or.&
& (e==zzero).or.(f==zzero)) then
write(0,*) 'XYZW assumes a,b,c,d,e,f are all nonzero'
else
!$omp parallel do private(i)
do i=1,m
y(i) = a*x(i)+b*y(i)
z(i) = c*y(i)+d*z(i)
w(i) = e*z(i)+f*w(i)
end do
end if
return
9999 continue
call fcpsb_serror()
return
end subroutine psi_zxyzw

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
use psb_base_mod, psb_protect_name => psb_cspasb
use psb_sort_mod
use psi_mod
@ -58,6 +58,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_), optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@ -65,6 +66,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
class(psb_i_base_vect_type), allocatable :: ivm
logical :: bld_and_
info = psb_success_
name = 'psb_spasb'
@ -93,7 +95,11 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
& ' Begin matrix assembly...'
if (present(bld_and)) then
bld_and_ = bld_and
else
bld_and_ = .false.
end if
!check on errors encountered in psdspins
if (a%is_bld()) then
@ -171,7 +177,49 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
end if
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_c_coo_sparse_mat) :: acoo
!!$ type(psb_c_csr_sparse_mat), allocatable :: aclip
!!$ type(psb_c_ecsr_sparse_mat), allocatable :: andclip
!!$ logical, parameter :: use_ecsr=.true.
!!$ allocate(aclip)
!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
!!$ allocate(a%ad,mold=a%a)
!!$ call a%ad%mv_from_coo(acoo,info)
!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
!!$ if (use_ecsr) then
!!$ allocate(andclip)
!!$ call andclip%mv_from_coo(acoo,info)
!!$ call move_alloc(andclip,a%and)
!!$ else
!!$ allocate(a%and,mold=a%a)
!!$ call a%and%mv_from_coo(acoo,info)
!!$ end if
!!$ if (.false.) then
!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%ad%print(25)
!!$ close(25)
!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%and%print(25)
!!$ close(25)
!!$ !call andclip%set_cols(n_col)
!!$ write(*,*) me,' ',trim(name),' ad ',&
!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
!!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else
if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and)
end if
if (debug_level >= psb_debug_ext_) then
ch_err=a%get_fmt()
write(debug_unit, *) me,' ',trim(name),': From SPCNV',&

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
use psb_base_mod, psb_protect_name => psb_dspasb
use psb_sort_mod
use psi_mod
@ -58,6 +58,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_), optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@ -65,6 +66,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
class(psb_i_base_vect_type), allocatable :: ivm
logical :: bld_and_
info = psb_success_
name = 'psb_spasb'
@ -93,7 +95,11 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
& ' Begin matrix assembly...'
if (present(bld_and)) then
bld_and_ = bld_and
else
bld_and_ = .false.
end if
!check on errors encountered in psdspins
if (a%is_bld()) then
@ -171,7 +177,49 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
end if
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_d_coo_sparse_mat) :: acoo
!!$ type(psb_d_csr_sparse_mat), allocatable :: aclip
!!$ type(psb_d_ecsr_sparse_mat), allocatable :: andclip
!!$ logical, parameter :: use_ecsr=.true.
!!$ allocate(aclip)
!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
!!$ allocate(a%ad,mold=a%a)
!!$ call a%ad%mv_from_coo(acoo,info)
!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
!!$ if (use_ecsr) then
!!$ allocate(andclip)
!!$ call andclip%mv_from_coo(acoo,info)
!!$ call move_alloc(andclip,a%and)
!!$ else
!!$ allocate(a%and,mold=a%a)
!!$ call a%and%mv_from_coo(acoo,info)
!!$ end if
!!$ if (.false.) then
!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%ad%print(25)
!!$ close(25)
!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%and%print(25)
!!$ close(25)
!!$ !call andclip%set_cols(n_col)
!!$ write(*,*) me,' ',trim(name),' ad ',&
!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
!!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else
if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and)
end if
if (debug_level >= psb_debug_ext_) then
ch_err=a%get_fmt()
write(debug_unit, *) me,' ',trim(name),': From SPCNV',&

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
use psb_base_mod, psb_protect_name => psb_sspasb
use psb_sort_mod
use psi_mod
@ -58,6 +58,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_), optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@ -65,6 +66,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
class(psb_i_base_vect_type), allocatable :: ivm
logical :: bld_and_
info = psb_success_
name = 'psb_spasb'
@ -93,7 +95,11 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
& ' Begin matrix assembly...'
if (present(bld_and)) then
bld_and_ = bld_and
else
bld_and_ = .false.
end if
!check on errors encountered in psdspins
if (a%is_bld()) then
@ -171,7 +177,49 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
end if
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_s_coo_sparse_mat) :: acoo
!!$ type(psb_s_csr_sparse_mat), allocatable :: aclip
!!$ type(psb_s_ecsr_sparse_mat), allocatable :: andclip
!!$ logical, parameter :: use_ecsr=.true.
!!$ allocate(aclip)
!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
!!$ allocate(a%ad,mold=a%a)
!!$ call a%ad%mv_from_coo(acoo,info)
!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
!!$ if (use_ecsr) then
!!$ allocate(andclip)
!!$ call andclip%mv_from_coo(acoo,info)
!!$ call move_alloc(andclip,a%and)
!!$ else
!!$ allocate(a%and,mold=a%a)
!!$ call a%and%mv_from_coo(acoo,info)
!!$ end if
!!$ if (.false.) then
!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%ad%print(25)
!!$ close(25)
!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%and%print(25)
!!$ close(25)
!!$ !call andclip%set_cols(n_col)
!!$ write(*,*) me,' ',trim(name),' ad ',&
!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
!!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else
if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and)
end if
if (debug_level >= psb_debug_ext_) then
ch_err=a%get_fmt()
write(debug_unit, *) me,' ',trim(name),': From SPCNV',&

@ -44,7 +44,7 @@
! psb_upd_perm_ Permutation(more memory)
!
!
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
use psb_base_mod, psb_protect_name => psb_zspasb
use psb_sort_mod
use psi_mod
@ -58,6 +58,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_), optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
logical, intent(in), optional :: bld_and
!....Locals....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, err_act
@ -65,6 +66,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
class(psb_i_base_vect_type), allocatable :: ivm
logical :: bld_and_
info = psb_success_
name = 'psb_spasb'
@ -93,7 +95,11 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
& ' Begin matrix assembly...'
if (present(bld_and)) then
bld_and_ = bld_and
else
bld_and_ = .false.
end if
!check on errors encountered in psdspins
if (a%is_bld()) then
@ -171,7 +177,49 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
end if
if (bld_and_) then
!!$ allocate(a%ad,mold=a%a)
!!$ allocate(a%and,mold=a%a)o
call a%split_nd(n_row,n_col,info)
!!$ block
!!$ character(len=1024) :: fname
!!$ type(psb_z_coo_sparse_mat) :: acoo
!!$ type(psb_z_csr_sparse_mat), allocatable :: aclip
!!$ type(psb_z_ecsr_sparse_mat), allocatable :: andclip
!!$ logical, parameter :: use_ecsr=.true.
!!$ allocate(aclip)
!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
!!$ allocate(a%ad,mold=a%a)
!!$ call a%ad%mv_from_coo(acoo,info)
!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
!!$ if (use_ecsr) then
!!$ allocate(andclip)
!!$ call andclip%mv_from_coo(acoo,info)
!!$ call move_alloc(andclip,a%and)
!!$ else
!!$ allocate(a%and,mold=a%a)
!!$ call a%and%mv_from_coo(acoo,info)
!!$ end if
!!$ if (.false.) then
!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%ad%print(25)
!!$ close(25)
!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!!$ open(25,file=fname)
!!$ call a%and%print(25)
!!$ close(25)
!!$ !call andclip%set_cols(n_col)
!!$ write(*,*) me,' ',trim(name),' ad ',&
!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
!!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else
if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and)
end if
if (debug_level >= psb_debug_ext_) then
ch_err=a%get_fmt()
write(debug_unit, *) me,' ',trim(name),': From SPCNV',&

@ -2018,3 +2018,252 @@ CPPFLAGS="$SAVE_CPPFLAGS";
])dnl
dnl @synopsis PAC_CHECK_SPGPU
dnl
dnl Will try to find the spgpu library and headers.
dnl
dnl Will use $CC
dnl
dnl If the test passes, will execute ACTION-IF-FOUND. Otherwise, ACTION-IF-NOT-FOUND.
dnl Note : This file will be likely to induce the compiler to create a module file
dnl (for a module called conftest).
dnl Depending on the compiler flags, this could cause a conftest.mod file to appear
dnl in the present directory, or in another, or with another name. So be warned!
dnl
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN(PAC_CHECK_SPGPU,
[SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_have_cuda" == "x"; then
PAC_CHECK_CUDA()
fi
dnl AC_MSG_NOTICE([From CUDA: $pac_cv_have_cuda ])
if test "x$pac_cv_have_cuda" == "xyes"; then
AC_ARG_WITH(spgpu, AC_HELP_STRING([--with-spgpu=DIR], [Specify the directory for SPGPU library and includes.]),
[pac_cv_spgpudir=$withval],
[pac_cv_spgpudir=''])
AC_LANG([C])
if test "x$pac_cv_spgpudir" != "x"; then
LIBS="-L$pac_cv_spgpudir/lib $LIBS"
GPU_INCLUDES="-I$pac_cv_spgpudir/include"
CPPFLAGS="$GPU_INCLUDES $CUDA_INCLUDES $CPPFLAGS"
GPU_LIBDIR="-L$pac_cv_spgpudir/lib"
fi
AC_MSG_CHECKING([spgpu dir $pac_cv_spgpudir])
AC_CHECK_HEADER([core.h],
[pac_gpu_header_ok=yes],
[pac_gpu_header_ok=no; GPU_INCLUDES=""])
if test "x$pac_gpu_header_ok" == "xyes" ; then
GPU_LIBS="-lspgpu $GPU_LIBDIR"
LIBS="$GPU_LIBS $CUDA_LIBS -lm $LIBS";
AC_MSG_CHECKING([for spgpuCreate in $GPU_LIBS])
AC_TRY_LINK_FUNC(spgpuCreate,
[pac_cv_have_spgpu=yes;pac_gpu_lib_ok=yes; ],
[pac_cv_have_spgpu=no;pac_gpu_lib_ok=no; GPU_LIBS=""])
AC_MSG_RESULT($pac_gpu_lib_ok)
if test "x$pac_cv_have_spgpu" == "xyes" ; then
AC_MSG_NOTICE([Have found SPGPU])
SPGPULIBNAME="libpsbgpu.a";
SPGPU_DIR="$pac_cv_spgpudir";
SPGPU_DEFINES="-DHAVE_SPGPU";
SPGPU_INCDIR="$SPGPU_DIR/include";
SPGPU_INCLUDES="-I$SPGPU_INCDIR";
SPGPU_LIBS="-lspgpu -L$SPGPU_DIR/lib";
LGPU=-lpsb_gpu
CUDA_DIR="$pac_cv_cuda_dir";
CUDA_DEFINES="-DHAVE_CUDA";
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
FDEFINES="$psblas_cv_define_prepend-DHAVE_GPU $psblas_cv_define_prepend-DHAVE_SPGPU $psblas_cv_define_prepend-DHAVE_CUDA $FDEFINES";
CDEFINES="-DHAVE_SPGPU -DHAVE_CUDA $CDEFINES" ;
fi
fi
fi
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
])dnl
dnl @synopsis PAC_CHECK_CUDA
dnl
dnl Will try to find the cuda library and headers.
dnl
dnl Will use $CC
dnl
dnl If the test passes, will execute ACTION-IF-FOUND. Otherwise, ACTION-IF-NOT-FOUND.
dnl Note : This file will be likely to induce the compiler to create a module file
dnl (for a module called conftest).
dnl Depending on the compiler flags, this could cause a conftest.mod file to appear
dnl in the present directory, or in another, or with another name. So be warned!
dnl
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN(PAC_CHECK_CUDA,
[AC_ARG_WITH(cuda, AC_HELP_STRING([--with-cuda=DIR], [Specify the CUDA install directory.]),
[pac_cv_cuda_dir=$withval],
[pac_cv_cuda_dir=''])
AC_LANG([C])
SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_cuda_dir" != "x"; then
CUDA_DIR="$pac_cv_cuda_dir"
LIBS="-L$pac_cv_cuda_dir/lib $LIBS"
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_DEFINES="-DHAVE_CUDA"
CPPFLAGS="$CUDA_INCLUDES $CPPFLAGS"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
if test -f "$pac_cv_cuda_dir/bin/nvcc"; then
CUDA_NVCC="$pac_cv_cuda_dir/bin/nvcc"
else
CUDA_NVCC="nvcc"
fi
fi
AC_MSG_CHECKING([cuda dir $pac_cv_cuda_dir])
AC_CHECK_HEADER([cuda_runtime.h],
[pac_cuda_header_ok=yes],
[pac_cuda_header_ok=no; CUDA_INCLUDES=""])
if test "x$pac_cuda_header_ok" == "xyes" ; then
CUDA_LIBS="-lcusparse -lcublas -lcudart $CUDA_LIBDIR"
LIBS="$CUDA_LIBS -lm $LIBS";
AC_MSG_CHECKING([for cudaMemcpy in $CUDA_LIBS])
AC_TRY_LINK_FUNC(cudaMemcpy,
[pac_cv_have_cuda=yes;pac_cuda_lib_ok=yes; ],
[pac_cv_have_cuda=no;pac_cuda_lib_ok=no; CUDA_LIBS=""])
AC_MSG_RESULT($pac_cuda_lib_ok)
fi
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
])dnl
dnl @synopsis PAC_ARG_WITH_CUDACC
dnl
dnl Test for --with-cudacc="set_of_cc".
dnl
dnl Defines the CC to compile for
dnl
dnl
dnl Example use:
dnl
dnl PAC_ARG_WITH_CUDACC
dnl
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN([PAC_ARG_WITH_CUDACC],
[
AC_ARG_WITH(cudacc,
AC_HELP_STRING([--with-cudacc], [A comma-separated list of CCs to compile to, for example,
--with-cudacc=50,60,70,75]),
[pac_cv_cudacc=$withval],
[pac_cv_cudacc=''])
])
AC_DEFUN(PAC_ARG_WITH_LIBRSB,
[SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
AC_ARG_WITH(librsb,
AC_HELP_STRING([--with-librsb], [The directory for LIBRSB, for example,
--with-librsb=/opt/packages/librsb]),
[pac_cv_librsb_dir=$withval],
[pac_cv_librsb_dir=''])
if test "x$pac_cv_librsb_dir" != "x"; then
LIBS="-L$pac_cv_librsb_dir $LIBS"
RSB_INCLUDES="-I$pac_cv_librsb_dir"
# CPPFLAGS="$GPU_INCLUDES $CUDA_INCLUDES $CPPFLAGS"
RSB_LIBDIR="-L$pac_cv_librsb_dir"
fi
#AC_MSG_CHECKING([librsb dir $pac_cv_librsb_dir])
AC_CHECK_HEADER([$pac_cv_librsb_dir/rsb.h],
[pac_rsb_header_ok=yes],
[pac_rsb_header_ok=no; RSB_INCLUDES=""])
if test "x$pac_rsb_header_ok" == "xyes" ; then
RSB_LIBS="-lrsb $RSB_LIBDIR"
# LIBS="$GPU_LIBS $CUDA_LIBS -lm $LIBS";
# AC_MSG_CHECKING([for spgpuCreate in $GPU_LIBS])
# AC_TRY_LINK_FUNC(spgpuCreate,
# [pac_cv_have_spgpu=yes;pac_gpu_lib_ok=yes; ],
# [pac_cv_have_spgpu=no;pac_gpu_lib_ok=no; GPU_LIBS=""])
# AC_MSG_RESULT($pac_gpu_lib_ok)
# if test "x$pac_cv_have_spgpu" == "xyes" ; then
# AC_MSG_NOTICE([Have found SPGPU])
RSBLIBNAME="librsb.a";
LIBRSB_DIR="$pac_cv_librsb_dir";
# SPGPU_DEFINES="-DHAVE_SPGPU";
LIBRSB_INCDIR="$LIBRSB_DIR";
LIBRSB_INCLUDES="-I$LIBRSB_INCDIR";
LIBRSB_LIBS="-lrsb -L$LIBRSB_DIR";
# CUDA_DIR="$pac_cv_cuda_dir";
LIBRSB_DEFINES="-DHAVE_RSB";
LRSB=-lpsb_rsb
# CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
# CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
FDEFINES="$LIBRSB_DEFINES $psblas_cv_define_prepend $FDEFINES";
CDEFINES="$LIBRSB_DEFINES $CDEFINES";#CDEFINES="-DHAVE_SPGPU -DHAVE_CUDA $CDEFINES";
fi
# fi
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
])
dnl
dnl @synopsis PAC_CHECK_CUDA_VERSION
dnl
dnl Will try to find the cuda version
dnl
dnl Will use $CC
dnl
dnl If the test passes, will execute ACTION-IF-FOUND. Otherwise, ACTION-IF-NOT-FOUND.
dnl Note : This file will be likely to induce the compiler to create a module file
dnl (for a module called conftest).
dnl Depending on the compiler flags, this could cause a conftest.mod file to appear
dnl in the present directory, or in another, or with another name. So be warned!
dnl
dnl @author Salvatore Filippone <salvatore.filippone@uniroma2.it>
dnl
AC_DEFUN(PAC_CHECK_CUDA_VERSION,
[AC_LANG_PUSH([C])
SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_have_cuda" == "x"; then
PAC_CHECK_CUDA()
fi
if test "x$pac_cv_have_cuda" == "xyes"; then
CUDA_DIR="$pac_cv_cuda_dir"
LIBS="-L$pac_cv_cuda_dir/lib $LIBS"
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_DEFINES="-DHAVE_CUDA"
CPPFLAGS="$CUDA_INCLUDES $CPPFLAGS"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
CUDA_LIBS="-lcusparse -lcublas -lcudart $CUDA_LIBDIR"
LIBS="$CUDA_LIBS -lm $LIBS";
AC_MSG_CHECKING([for CUDA version])
AC_LINK_IFELSE([AC_LANG_SOURCE([
#include <stdio.h>
#include <cuda.h>
int main(int argc, char **argv)
{
printf("%d",CUDA_VERSION);
return(0);
} ])],
[pac_cv_cuda_version=`./conftest${ac_exeext} | sed 's/^ *//'`;],
[pac_cv_cuda_version="unknown";])
AC_MSG_RESULT($pac_cv_cuda_version)
fi
AC_LANG_POP([C])
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
])dnl

388
configure vendored

@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.71 for PSBLAS 3.7.0.
# Generated by GNU Autoconf 2.71 for PSBLAS 3.8.1.
#
# Report bugs to <https://github.com/sfilippone/psblas3/issues>.
#
@ -611,8 +611,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='PSBLAS'
PACKAGE_TARNAME='psblas'
PACKAGE_VERSION='3.7.0'
PACKAGE_STRING='PSBLAS 3.7.0'
PACKAGE_VERSION='3.8.1'
PACKAGE_STRING='PSBLAS 3.8.1'
PACKAGE_BUGREPORT='https://github.com/sfilippone/psblas3/issues'
PACKAGE_URL=''
@ -653,6 +653,20 @@ ac_subst_vars='am__EXEEXT_FALSE
am__EXEEXT_TRUE
LTLIBOBJS
LIBOBJS
LCUDA
CUDALD
CUDAD
CUDEFINES
CUDA_NVCC
CUDA_SHORT_VERSION
CUDA_VERSION
CUDA_LIBS
CUDA_INCLUDES
CUDA_DEFINES
CUDA_DIR
EXTRALDLIBS
SPGPU_LIBS
SPGPU_FLAGS
METISINCFILE
UTILLIBNAME
METHDLIBNAME
@ -815,7 +829,6 @@ enable_openmp
with_blas
with_blasdir
with_lapack
with_rsb
with_metis
with_metisincfile
with_metisdir
@ -825,6 +838,8 @@ with_amd
with_amddir
with_amdincdir
with_amdlibdir
with_cuda
with_cudacc
'
ac_precious_vars='build_alias
host_alias
@ -1390,7 +1405,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
\`configure' configures PSBLAS 3.7.0 to adapt to many kinds of systems.
\`configure' configures PSBLAS 3.8.1 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@ -1457,7 +1472,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of PSBLAS 3.7.0:";;
short | recursive ) echo "Configuration of PSBLAS 3.8.1:";;
esac
cat <<\_ACEOF
@ -1505,12 +1520,6 @@ Optional Packages:
--with-blas=<lib> use BLAS library <lib>
--with-blasdir=<dir> search for BLAS library in <dir>
--with-lapack=<lib> use LAPACK library <lib>
--with-rsb Specify Recursive Sparse BLAS library linkage info
(that is, the output of librsb-config --static
--ldflags, or a directory where the usual
bin/include/lib subdirs with a regular RSB
installation resides, or nothing to make the
configure script invoke librsb-config)
--with-metis=LIBNAME Specify the library name for METIS library. Default:
"-lmetis"
--with-metisincfile=DIR Specify the name for METIS include file.
@ -1523,6 +1532,9 @@ Optional Packages:
--with-amddir=DIR Specify the directory for AMD library and includes.
--with-amdincdir=DIR Specify the directory for AMD includes.
--with-amdlibdir=DIR Specify the directory for AMD library.
--with-cuda=DIR Specify the CUDA install directory.
--with-cudacc A comma-separated list of CCs to compile to, for
example, --with-cudacc=50,60,70,75
Some influential environment variables:
FC Fortran compiler command
@ -1607,7 +1619,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
PSBLAS configure 3.7.0
PSBLAS configure 3.8.1
generated by GNU Autoconf 2.71
Copyright (C) 2021 Free Software Foundation, Inc.
@ -2291,7 +2303,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by PSBLAS $as_me 3.7.0, which was
It was created by PSBLAS $as_me 3.8.1, which was
generated by GNU Autoconf 2.71. Invocation command line was
$ $0$ac_configure_args_raw
@ -3265,7 +3277,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
# VERSION is the file containing the PSBLAS version code
# FIXME
psblas_cv_version="3.7.0"
psblas_cv_version="3.8.1"
# A sample source file
@ -3440,7 +3452,7 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5'
ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_fc_compiler_gnu
if test -n "$ac_tool_prefix"; then
for ac_prog in ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 ifort ifc nagfor gfortran
for ac_prog in ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 flang-new ifort ifc nagfor gfortran
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
@ -3489,7 +3501,7 @@ fi
fi
if test -z "$FC"; then
ac_ct_FC=$FC
for ac_prog in ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 ifort ifc nagfor gfortran
for ac_prog in ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 flang-new ifort ifc nagfor gfortran
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
@ -3916,7 +3928,7 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
for ac_prog in xlc pgcc icc gcc cc
for ac_prog in xlc pgcc clang icc gcc cc
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
@ -3965,7 +3977,7 @@ fi
fi
if test -z "$CC"; then
ac_ct_CC=$CC
for ac_prog in xlc pgcc icc gcc cc
for ac_prog in xlc pgcc clang icc gcc cc
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
@ -4412,7 +4424,7 @@ if test -z "$CXX"; then
CXX=$CCC
else
if test -n "$ac_tool_prefix"; then
for ac_prog in CC xlc++ icpc g++
for ac_prog in CC xlc++ clang++ icpc g++
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
@ -4461,7 +4473,7 @@ fi
fi
if test -z "$CXX"; then
ac_ct_CXX=$CXX
for ac_prog in CC xlc++ icpc g++
for ac_prog in CC xlc++ clang++ icpc g++
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
@ -6393,7 +6405,7 @@ fi
# Define the identity of the package.
PACKAGE='psblas'
VERSION='3.7.0'
VERSION='3.8.1'
printf "%s\n" "#define PACKAGE \"$PACKAGE\"" >>confdefs.h
@ -6862,10 +6874,12 @@ if test x"$psblas_cv_fc" == "x" ; then
# Sun compiler detection
psblas_cv_fc="sun"
elif eval "$MPIFC -V 2>&1 | grep Portland 2>/dev/null" ; then
elif eval "$MPIFC --version 2>&1 | grep flang-new 2>/dev/null" ; then
# Portland group compiler detection
psblas_cv_fc="pg"
psblas_cv_fc="flang"
psblas_cv_define_prepend=""
FDEFINES="$psblas_cv_define_prepend-DFLANG $FDEFINES"
elif eval "$MPIFC -V 2>&1 | grep Intel.*Fortran.*Compiler 2>/dev/null" ; then
# Intel compiler identification
@ -7289,6 +7303,9 @@ if test "X$FCOPT" == "X" ; then
elif test "X$psblas_cv_fc" == X"pg" ; then
# other compilers ..
FCOPT="-fast $FCOPT"
elif test "X$psblas_cv_fc" == X"flang" ; then
# other compilers ..
FCOPT="-O3"
# NOTE : PG & Sun use -fast instead -O3
elif test "X$psblas_cv_fc" == X"sun" ; then
# other compilers ..
@ -7533,7 +7550,6 @@ fi
if test x"$pac_cv_serial_mpi" == x"yes" ; then
FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES";
CDEFINES="-DSERIAL_MPI $CDEFINES"
CXXDEFINES="-DSERIAL_MPI $CXXDEFINES"
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking MPI Fortran 2008 interface" >&5
printf %s "checking MPI Fortran 2008 interface... " >&6; }
@ -10001,31 +10017,6 @@ fi
#AC_CHECK_LIB(umf,umfpack_di_solve,psblas_cv_have_umfpack=yes,psblas_cv_have_umfpack=no,[amd])
# Check whether --with-rsb was given.
if test ${with_rsb+y}
then :
withval=$with_rsb; if test x"$withval" = xno; then
want_rsb_libs= ; else if test x"$withval" = xyes ; then want_rsb_libs=yes ; else want_rsb_libs="$withval" ; fi ; fi
else $as_nop
want_rsb_libs=""
fi
if test x"$want_rsb_libs" != x ; then
if test x"$want_rsb_libs" = xyes ; then
want_rsb_libs="`librsb-config --static --ldflags`"
else
if test -d "$want_rsb_libs" ; then
want_rsb_libs="`$want_rsb_libs/bin/librsb-config --static --ldflags`"
else
true;
# we assume want_rsb_libs are linkage parameters
fi
fi
FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_LIBRSB"
fi
RSB_LIBS="$want_rsb_libs"
LIBS="$RSB_LIBS ${LIBS}"
# Check whether --with-metis was given.
if test ${with_metis+y}
@ -10612,6 +10603,274 @@ fi
# Check whether --with-cuda was given.
if test ${with_cuda+y}
then :
withval=$with_cuda; pac_cv_cuda_dir=$withval
else $as_nop
pac_cv_cuda_dir=''
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_cuda_dir" != "x"; then
CUDA_DIR="$pac_cv_cuda_dir"
LIBS="-L$pac_cv_cuda_dir/lib $LIBS"
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_DEFINES="-DHAVE_CUDA"
CPPFLAGS="$CUDA_INCLUDES $CPPFLAGS"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
if test -f "$pac_cv_cuda_dir/bin/nvcc"; then
CUDA_NVCC="$pac_cv_cuda_dir/bin/nvcc"
else
CUDA_NVCC="nvcc"
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking cuda dir $pac_cv_cuda_dir" >&5
printf %s "checking cuda dir $pac_cv_cuda_dir... " >&6; }
ac_fn_c_check_header_compile "$LINENO" "cuda_runtime.h" "ac_cv_header_cuda_runtime_h" "$ac_includes_default"
if test "x$ac_cv_header_cuda_runtime_h" = xyes
then :
pac_cuda_header_ok=yes
else $as_nop
pac_cuda_header_ok=no; CUDA_INCLUDES=""
fi
if test "x$pac_cuda_header_ok" == "xyes" ; then
CUDA_LIBS="-lcusparse -lcublas -lcudart $CUDA_LIBDIR"
LIBS="$CUDA_LIBS -lm $LIBS";
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cudaMemcpy in $CUDA_LIBS" >&5
printf %s "checking for cudaMemcpy in $CUDA_LIBS... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char cudaMemcpy ();
int
main (void)
{
return cudaMemcpy ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
pac_cv_have_cuda=yes;pac_cuda_lib_ok=yes;
else $as_nop
pac_cv_have_cuda=no;pac_cuda_lib_ok=no; CUDA_LIBS=""
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $pac_cuda_lib_ok" >&5
printf "%s\n" "$pac_cuda_lib_ok" >&6; }
fi
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
if test "x$pac_cv_have_cuda" == "xyes"; then
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_have_cuda" == "x"; then
# Check whether --with-cuda was given.
if test ${with_cuda+y}
then :
withval=$with_cuda; pac_cv_cuda_dir=$withval
else $as_nop
pac_cv_cuda_dir=''
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
SAVE_LIBS="$LIBS"
SAVE_CPPFLAGS="$CPPFLAGS"
if test "x$pac_cv_cuda_dir" != "x"; then
CUDA_DIR="$pac_cv_cuda_dir"
LIBS="-L$pac_cv_cuda_dir/lib $LIBS"
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_DEFINES="-DHAVE_CUDA"
CPPFLAGS="$CUDA_INCLUDES $CPPFLAGS"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
if test -f "$pac_cv_cuda_dir/bin/nvcc"; then
CUDA_NVCC="$pac_cv_cuda_dir/bin/nvcc"
else
CUDA_NVCC="nvcc"
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking cuda dir $pac_cv_cuda_dir" >&5
printf %s "checking cuda dir $pac_cv_cuda_dir... " >&6; }
ac_fn_c_check_header_compile "$LINENO" "cuda_runtime.h" "ac_cv_header_cuda_runtime_h" "$ac_includes_default"
if test "x$ac_cv_header_cuda_runtime_h" = xyes
then :
pac_cuda_header_ok=yes
else $as_nop
pac_cuda_header_ok=no; CUDA_INCLUDES=""
fi
if test "x$pac_cuda_header_ok" == "xyes" ; then
CUDA_LIBS="-lcusparse -lcublas -lcudart $CUDA_LIBDIR"
LIBS="$CUDA_LIBS -lm $LIBS";
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cudaMemcpy in $CUDA_LIBS" >&5
printf %s "checking for cudaMemcpy in $CUDA_LIBS... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char cudaMemcpy ();
int
main (void)
{
return cudaMemcpy ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
pac_cv_have_cuda=yes;pac_cuda_lib_ok=yes;
else $as_nop
pac_cv_have_cuda=no;pac_cuda_lib_ok=no; CUDA_LIBS=""
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $pac_cuda_lib_ok" >&5
printf "%s\n" "$pac_cuda_lib_ok" >&6; }
fi
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
fi
if test "x$pac_cv_have_cuda" == "xyes"; then
CUDA_DIR="$pac_cv_cuda_dir"
LIBS="-L$pac_cv_cuda_dir/lib $LIBS"
CUDA_INCLUDES="-I$pac_cv_cuda_dir/include"
CUDA_DEFINES="-DHAVE_CUDA"
CPPFLAGS="$CUDA_INCLUDES $CPPFLAGS"
CUDA_LIBDIR="-L$pac_cv_cuda_dir/lib64 -L$pac_cv_cuda_dir/lib"
CUDA_LIBS="-lcusparse -lcublas -lcudart $CUDA_LIBDIR"
LIBS="$CUDA_LIBS -lm $LIBS";
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CUDA version" >&5
printf %s "checking for CUDA version... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdio.h>
#include <cuda.h>
int main(int argc, char **argv)
{
printf("%d",CUDA_VERSION);
return(0);
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
pac_cv_cuda_version=`./conftest${ac_exeext} | sed 's/^ *//'`;
else $as_nop
pac_cv_cuda_version="unknown";
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $pac_cv_cuda_version" >&5
printf "%s\n" "$pac_cv_cuda_version" >&6; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
LIBS="$SAVE_LIBS"
CPPFLAGS="$SAVE_CPPFLAGS"
CUDA_VERSION="$pac_cv_cuda_version";
CUDA_SHORT_VERSION=$(expr $pac_cv_cuda_version / 1000);
HAVE_CUDA="yes";
SPGPU_LIBS="-lspgpu";
CUDAD=cudad;
CUDALD=cudald;
LCUDA="-lpsb_cuda";
EXTRALDLIBS="-lstdc++";
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: At this point GPUTARGET is $CUDAD $CUDALD" >&5
printf "%s\n" "$as_me: At this point GPUTARGET is $CUDAD $CUDALD" >&6;}
# Check whether --with-cudacc was given.
if test ${with_cudacc+y}
then :
withval=$with_cudacc; pac_cv_cudacc=$withval
else $as_nop
pac_cv_cudacc=''
fi
if test "x$pac_cv_cudacc" == "x"; then
pac_cv_cudacc="50,60,70,75";
CUDA_CC="$pac_cv_cudacc";
fi
if (( $pac_cv_cuda_version >= 11070 ))
then
CUDEFINES="--dopt=on";
fi
for cc in `echo $pac_cv_cudacc|sed 's/,/ /gi'`
do
CUDEFINES="$CUDEFINES -gencode arch=compute_$cc,code=sm_$cc";
done
if test "x$pac_cv_cuda_version" != "xunknown"; then
CUDEFINES="$CUDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
FDEFINES="$FDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
CDEFINES="$CDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
fi
fi
if test "x$pac_cv_ipk_size" != "x4"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: For CUDA I need psb_ipk_ to be 4 bytes but it is $pac_cv_ipk_size, disabling CUDA/SPGPU" >&5
printf "%s\n" "$as_me: For CUDA I need psb_ipk_ to be 4 bytes but it is $pac_cv_ipk_size, disabling CUDA/SPGPU" >&6;}
HAVE_CUDA="no";
CUDA_CC="";
SPGPU_LIBS="";
CUDAD="";
CUDALD="";
CUDEFINES="";
CUDA_INCLUDES="";
CUDA_LIBS="";
fi
###############################################################################
# Library target directory and archive files.
###############################################################################
@ -10669,9 +10928,9 @@ UTILLIBNAME=libpsb_util.a
PSBLASRULES='
PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(AMD_LIB) $(LIBS)
CXXDEFINES=$(PSBCXXDEFINES)
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
CXXDEFINES=$(PSBCXXDEFINES) $(CUDA_DEFINES)
CDEFINES=$(PSBCDEFINES) $(CUDA_DEFINES)
FDEFINES=$(PSBFDEFINES) $(CUDA_DEFINES)
# These should be portable rules, arent they?
@ -10690,6 +10949,19 @@ FDEFINES=$(PSBFDEFINES)
@ -11264,7 +11536,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by PSBLAS $as_me 3.7.0, which was
This file was extended by PSBLAS $as_me 3.8.1, which was
generated by GNU Autoconf 2.71. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@ -11323,7 +11595,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config='$ac_cs_config_escaped'
ac_cs_version="\\
PSBLAS config.status 3.7.0
PSBLAS config.status 3.8.1
configured by $0, generated by GNU Autoconf 2.71,
with options \\"\$ac_cs_config\\"
@ -12024,6 +12296,9 @@ fi
FCOPT : ${FCOPT}
CCOPT : ${CCOPT}
CUDA : ${HAVE_CUDA}
CUDA_CC : ${CUDA_CC}
BLAS : ${BLAS_LIBS}
METIS usable : ${psblas_cv_have_metis}
@ -12054,6 +12329,9 @@ printf "%s\n" "$as_me:
FCOPT : ${FCOPT}
CCOPT : ${CCOPT}
CUDA : ${HAVE_CUDA}
CUDA_CC : ${CUDA_CC}
BLAS : ${BLAS_LIBS}
METIS usable : ${psblas_cv_have_metis}

@ -36,11 +36,11 @@ dnl NOTE : There is no cross compilation support.
###############################################################################
# NOTE: the literal for version (the second argument to AC_INIT should be a literal!)
AC_INIT([PSBLAS],3.7.0, [https://github.com/sfilippone/psblas3/issues])
AC_INIT([PSBLAS],3.8.1, [https://github.com/sfilippone/psblas3/issues])
# VERSION is the file containing the PSBLAS version code
# FIXME
psblas_cv_version="3.7.0"
psblas_cv_version="3.8.1"
# A sample source file
AC_CONFIG_SRCDIR([base/modules/psb_base_mod.f90])
@ -100,17 +100,17 @@ dnl We set our own FC flags, ignore those from AC_PROG_FC but not those from the
dnl environment variable. Same for C
dnl
save_FCFLAGS="$FCFLAGS";
AC_PROG_FC([ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 ifort ifc nagfor gfortran])
AC_PROG_FC([ftn xlf2003_r xlf2003 xlf95_r xlf95 xlf90 xlf pgf95 pgf90 flang-new ifort ifc nagfor gfortran])
FCFLAGS="$save_FCFLAGS";
save_CFLAGS="$CFLAGS";
AC_PROG_CC([xlc pgcc icc gcc cc ])
AC_PROG_CC([xlc pgcc clang icc gcc cc ])
if test "x$ac_cv_prog_cc_stdc" == "xno" ; then
AC_MSG_ERROR([Problem : Need a C99 compiler ! ])
else
C99OPT="$ac_cv_prog_cc_stdc";
fi
CFLAGS="$save_CFLAGS";
AC_PROG_CXX([CC xlc++ icpc g++])
AC_PROG_CXX([CC xlc++ clang++ icpc g++])
dnl AC_PROG_F90 doesn't exist, at the time of writing this !
dnl AC_PROG_F90
@ -248,10 +248,12 @@ if test x"$psblas_cv_fc" == "x" ; then
# Sun compiler detection
psblas_cv_fc="sun"
elif eval "$MPIFC -V 2>&1 | grep Portland 2>/dev/null" ; then
elif eval "$MPIFC --version 2>&1 | grep flang-new 2>/dev/null" ; then
# Portland group compiler detection
psblas_cv_fc="pg"
psblas_cv_fc="flang"
psblas_cv_define_prepend=""
FDEFINES="$psblas_cv_define_prepend-DFLANG $FDEFINES"
elif eval "$MPIFC -V 2>&1 | grep Intel.*Fortran.*Compiler 2>/dev/null" ; then
# Intel compiler identification
@ -427,6 +429,9 @@ if test "X$FCOPT" == "X" ; then
elif test "X$psblas_cv_fc" == X"pg" ; then
# other compilers ..
FCOPT="-fast $FCOPT"
elif test "X$psblas_cv_fc" == X"flang" ; then
# other compilers ..
FCOPT="-O3"
# NOTE : PG & Sun use -fast instead -O3
elif test "X$psblas_cv_fc" == X"sun" ; then
# other compilers ..
@ -730,23 +735,23 @@ PAC_MAKE_IS_GNUMAKE
# Note : also umfdi_local_search, ...
#AC_CHECK_LIB(umf,umfpack_di_solve,psblas_cv_have_umfpack=yes,psblas_cv_have_umfpack=no,[amd])
AC_ARG_WITH(rsb, AS_HELP_STRING([--with-rsb], [Specify Recursive Sparse BLAS library linkage info (that is, the output of librsb-config --static --ldflags, or a directory where the usual bin/include/lib subdirs with a regular RSB installation resides, or nothing to make the configure script invoke librsb-config)]), [if test x"$withval" = xno; then
want_rsb_libs= ; else if test x"$withval" = xyes ; then want_rsb_libs=yes ; else want_rsb_libs="$withval" ; fi ; fi], [want_rsb_libs=""])
if test x"$want_rsb_libs" != x ; then
if test x"$want_rsb_libs" = xyes ; then
want_rsb_libs="`librsb-config --static --ldflags`"
else
if test -d "$want_rsb_libs" ; then
want_rsb_libs="`$want_rsb_libs/bin/librsb-config --static --ldflags`"
else
true;
# we assume want_rsb_libs are linkage parameters
fi
fi
FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_LIBRSB"
fi
RSB_LIBS="$want_rsb_libs"
LIBS="$RSB_LIBS ${LIBS}"
dnl AC_ARG_WITH(rsb, AS_HELP_STRING([--with-rsb], [Specify Recursive Sparse BLAS library linkage info (that is, the output of librsb-config --static --ldflags, or a directory where the usual bin/include/lib subdirs with a regular RSB installation resides, or nothing to make the configure script invoke librsb-config)]), [if test x"$withval" = xno; then
dnl want_rsb_libs= ; else if test x"$withval" = xyes ; then want_rsb_libs=yes ; else want_rsb_libs="$withval" ; fi ; fi], [want_rsb_libs=""])
dnl if test x"$want_rsb_libs" != x ; then
dnl if test x"$want_rsb_libs" = xyes ; then
dnl want_rsb_libs="`librsb-config --static --ldflags`"
dnl else
dnl if test -d "$want_rsb_libs" ; then
dnl want_rsb_libs="`$want_rsb_libs/bin/librsb-config --static --ldflags`"
dnl else
dnl true;
dnl # we assume want_rsb_libs are linkage parameters
dnl fi
dnl fi
dnl FDEFINES="$FDEFINES $psblas_cv_define_prepend-DHAVE_LIBRSB"
dnl fi
dnl RSB_LIBS="$want_rsb_libs"
dnl LIBS="$RSB_LIBS ${LIBS}"
dnl AC_CHECK_HEADERS([rsb.h], [ LIBS="${LIBS} $want_rsb_libs"], [])
PAC_CHECK_METIS
@ -791,6 +796,57 @@ fi
PAC_CHECK_CUDA()
if test "x$pac_cv_have_cuda" == "xyes"; then
PAC_CHECK_CUDA_VERSION()
CUDA_VERSION="$pac_cv_cuda_version";
CUDA_SHORT_VERSION=$(expr $pac_cv_cuda_version / 1000);
dnl PAC_CHECK_SPGPU()
HAVE_CUDA="yes";
SPGPU_LIBS="-lspgpu";
CUDAD=cudad;
CUDALD=cudald;
LCUDA="-lpsb_cuda";
EXTRALDLIBS="-lstdc++";
AC_MSG_NOTICE([At this point GPUTARGET is $CUDAD $CUDALD])
PAC_ARG_WITH_CUDACC()
if test "x$pac_cv_cudacc" == "x"; then
pac_cv_cudacc="50,60,70,75";
CUDA_CC="$pac_cv_cudacc";
fi
if (( $pac_cv_cuda_version >= 11070 ))
then
CUDEFINES="--dopt=on";
fi
for cc in `echo $pac_cv_cudacc|sed 's/,/ /gi'`
do
CUDEFINES="$CUDEFINES -gencode arch=compute_$cc,code=sm_$cc";
done
if test "x$pac_cv_cuda_version" != "xunknown"; then
CUDEFINES="$CUDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
FDEFINES="$FDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
CDEFINES="$CDEFINES -DCUDA_SHORT_VERSION=${CUDA_SHORT_VERSION} -DCUDA_VERSION=${CUDA_VERSION}"
fi
fi
if test "x$pac_cv_ipk_size" != "x4"; then
AC_MSG_NOTICE([For CUDA I need psb_ipk_ to be 4 bytes but it is $pac_cv_ipk_size, disabling CUDA/SPGPU])
HAVE_CUDA="no";
CUDA_CC="";
SPGPU_LIBS="";
CUDAD="";
CUDALD="";
CUDEFINES="";
CUDA_INCLUDES="";
CUDA_LIBS="";
fi
###############################################################################
# Library target directory and archive files.
###############################################################################
@ -848,9 +904,9 @@ AC_SUBST(FINCLUDES)
PSBLASRULES='
PSBLDLIBS=$(LAPACK) $(BLAS) $(METIS_LIB) $(AMD_LIB) $(LIBS)
CDEFINES=$(PSBCDEFINES)
FDEFINES=$(PSBFDEFINES)
CXXDEFINES=$(PSBCXXDEFINES)
CXXDEFINES=$(PSBCXXDEFINES) $(CUDA_DEFINES)
CDEFINES=$(PSBCDEFINES) $(CUDA_DEFINES)
FDEFINES=$(PSBFDEFINES) $(CUDA_DEFINES)
# These should be portable rules, arent they?
@ -872,7 +928,23 @@ AC_SUBST(PRECLIBNAME)
AC_SUBST(METHDLIBNAME)
AC_SUBST(UTILLIBNAME)
AC_SUBST(METISINCFILE)
AC_SUBST(SPGPU_FLAGS)
AC_SUBST(SPGPU_LIBS)
dnl AC_SUBST(SPGPU_DIR)
dnl AC_SUBST(SPGPU_INCLUDES)
dnl AC_SUBST(SPGPU_INCDIR)
AC_SUBST(EXTRALDLIBS)
AC_SUBST(CUDA_DIR)
AC_SUBST(CUDA_DEFINES)
AC_SUBST(CUDA_INCLUDES)
AC_SUBST(CUDA_LIBS)
AC_SUBST(CUDA_VERSION)
AC_SUBST(CUDA_SHORT_VERSION)
AC_SUBST(CUDA_NVCC)
AC_SUBST(CUDEFINES)
AC_SUBST(CUDAD)
AC_SUBST(CUDALD)
AC_SUBST(LCUDA)
###############################################################################
# the following files will be created by Automake
@ -897,6 +969,9 @@ AC_MSG_NOTICE([
FCOPT : ${FCOPT}
CCOPT : ${CCOPT}
CUDA : ${HAVE_CUDA}
CUDA_CC : ${CUDA_CC}
BLAS : ${BLAS_LIBS}
METIS usable : ${psblas_cv_have_metis}

@ -0,0 +1,37 @@
TOPDIR=../..
include $(TOPDIR)/Make.inc
#
# Libraries used
#
PSBLIBDIR=$(PSBLASDIR)/lib/
PSBINCDIR=$(PSBLASDIR)/include
LIBDIR=$(TOPDIR)/lib
INCDIR=$(TOPDIR)/include
PSBLAS_LIB= -L$(PSBLIBDIR) -lpsb_util -lpsb_base
#-lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS)
#
# Compilers and such
#
#CCOPT= -g
FINCLUDES=$(FMFLAG). $(FMFLAG)$(INCDIR) $(FMFLAG)$(PSBINCDIR) $(FIFLAG).
CINCLUDES=$(SPGPU_INCLUDES) $(CUDA_INCLUDES) -I.. -I$(INCDIR)
LIBNAME=libpsb_gpu.a
CUDAOBJS=psi_cuda_c_CopyCooToElg.o psi_cuda_c_CopyCooToHlg.o \
psi_cuda_d_CopyCooToElg.o psi_cuda_d_CopyCooToHlg.o \
psi_cuda_s_CopyCooToElg.o psi_cuda_s_CopyCooToHlg.o \
psi_cuda_z_CopyCooToElg.o psi_cuda_z_CopyCooToHlg.o
objs: $(CUDAOBJS)
lib: objs
ar cur ../$(LIBNAME) $(CUDAOBJS)
$(CUDAOBJS): psi_cuda_common.cuh psi_cuda_CopyCooToElg.cuh psi_cuda_CopyCooToHlg.cuh
clean:
/bin/rm -f $(CUDAOBJS)

@ -0,0 +1,104 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#include "psi_cuda_common.cuh"
#undef GEN_PSI_FUNC_NAME
#define GEN_PSI_FUNC_NAME(x) CONCAT(CONCAT(psi_cuda_,x),_CopyCooToElg)
#define THREAD_BLOCK 256
#ifdef __cplusplus
extern "C" {
#endif
void GEN_PSI_FUNC_NAME(TYPE_SYMBOL)(spgpuHandle_t handle, int nr, int nc, int nza,
int baseIdx, int hacksz, int ldv, int nzm,
int *rS,int *devIdisp, int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM);
#ifdef __cplusplus
}
#endif
__global__ void CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_krn)(int ii, int nrws, int nr, int nza,
int baseIdx, int hacksz, int ldv, int nzm,
int *rS, int *devIdisp, int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM)
{
int ir, k, ipnt, rsz,jc;
int ki = threadIdx.x + blockIdx.x * (THREAD_BLOCK);
int i=ii+ki;
int idval=0;
if (ki >= nrws) return;
if (i >= nr) return;
ipnt=devIdisp[i];
rsz=rS[i];
ir = i;
for (k=0; k<rsz; k++) {
if (devJa[ipnt] == i+baseIdx) idval = ipnt-devIdisp[i]+baseIdx;
rP[ir] = devJa[ipnt];
cM[ir] = devVal[ipnt];
ir += ldv;
ipnt++;
}
// Here we are assuming that devJa[] has at least one valid entry
// Pick one valid value.
jc = devJa[devIdisp[1]];
for (k=rsz; k<nzm; k++) {
rP[ir] = jc;
cM[ir] = CONCAT(zero_,VALUE_TYPE)();
ir += ldv;
}
idiag[i]=idval;
}
void CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_)(spgpuHandle_t handle, int nrws, int i, int nr, int nza,
int baseIdx, int hacksz, int ldv, int nzm,
int *rS,int *devIdisp, int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM)
{
dim3 block (THREAD_BLOCK, 1);
dim3 grid ((nrws + THREAD_BLOCK - 1) / THREAD_BLOCK);
CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_krn)
<<< grid, block, 0, handle->currentStream >>>(i,nrws, nr, nza, baseIdx, hacksz, ldv, nzm,
rS,devIdisp,devJa,devVal,idiag, rP,cM);
}
void
GEN_PSI_FUNC_NAME(TYPE_SYMBOL)
(spgpuHandle_t handle, int nr, int nc, int nza, int baseIdx, int hacksz, int ldv, int nzm,
int *rS,int *devIdisp, int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM)
{ int i,j, nrws;
//int maxNForACall = THREAD_BLOCK*handle->maxGridSizeX;
int maxNForACall = max(handle->maxGridSizeX, THREAD_BLOCK*handle->maxGridSizeX);
//fprintf(stderr,"Loop on j: %d\n",j);
for (i=0; i<nr; i+=nrws) {
nrws = MIN(maxNForACall, nr - i);
//fprintf(stderr,"ifirst: %d i : %d nrws: %d i + ifirst + (nrws -1) -1 %d \n",ifirst,i,nrws,i + ifirst + (nrws -1) -1);
CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_)(handle,nrws,i, nr, nza, baseIdx, hacksz, ldv, nzm,
rS,devIdisp, devJa, devVal, idiag, rP, cM);
}
}

@ -0,0 +1,108 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#include "psi_cuda_common.cuh"
#undef GEN_PSI_FUNC_NAME
#define GEN_PSI_FUNC_NAME(x) CONCAT(CONCAT(psi_cuda_,x),_CopyCooToHlg)
#define THREAD_BLOCK 256
#ifdef __cplusplus
extern "C" {
#endif
void GEN_PSI_FUNC_NAME(TYPE_SYMBOL)(spgpuHandle_t handle, int nr, int nc, int nza, int baseIdx, int hacksz,
int noffs, int isz, int *rS, int *hackOffs, int *devIdisp,
int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM);
#ifdef __cplusplus
}
#endif
__global__ void CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_krn)(int ii, int nrws, int nr, int nza,
int baseIdx, int hacksz, int noffs, int isz,
int *rS, int *hackOffs, int *devIdisp,
int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM)
{
int ir, k, ipnt, rsz,jc;
int ki = threadIdx.x + blockIdx.x * (THREAD_BLOCK);
int i=ii+ki;
if (ki >= nrws) return;
if (i<nr) {
int hackId = i / hacksz;
int hackLaneId = i % hacksz;
int hackOffset = hackOffs[hackId] + hackLaneId;
int nzm = (hackOffs[hackId+1]-hackOffs[hackId])/hacksz;
int idval=0;
rsz = rS[i];
ipnt = devIdisp[i];
ir = hackOffset;
for (k=0; k<rsz; k++) {
cM[ir] = devVal[ipnt];
if (devJa[ipnt] == i+baseIdx) idval = ipnt-devIdisp[i]+baseIdx;
rP[ir] = devJa[ipnt];
ir += hacksz;
ipnt++;
}
// Here we are assuming that devJa[] has at least one valid entry
// Pick one valid value.
jc = devJa[devIdisp[1]];
for (k=rsz; k<nzm; k++) {
rP[ir] = jc;
cM[ir] = CONCAT(zero_,VALUE_TYPE)();
ir += hacksz;
}
idiag[i]=idval;
}
}
void CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_)(spgpuHandle_t handle, int nrws, int i,
int nr, int nza, int baseIdx, int hacksz, int noffs, int isz,
int *rS, int *hackOffs, int *devIdisp, int *devJa,
VALUE_TYPE *devVal, int *idiag, int *rP, VALUE_TYPE *cM)
{
dim3 block (THREAD_BLOCK, 1);
dim3 grid ((nrws + THREAD_BLOCK - 1) / THREAD_BLOCK);
CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_krn)
<<< grid, block, 0, handle->currentStream >>>(i,nrws,nr, nza, baseIdx, hacksz, noffs, isz,
rS,hackOffs,devIdisp,devJa,devVal,idiag,rP,cM);
}
void GEN_PSI_FUNC_NAME(TYPE_SYMBOL)(spgpuHandle_t handle, int nr, int nc, int nza,
int baseIdx, int hacksz, int noffs, int isz,
int *rS, int *hackOffs, int *devIdisp,
int *devJa, VALUE_TYPE *devVal,
int *idiag, int *rP, VALUE_TYPE *cM)
{ int i, nrws;
//int maxNForACall = THREAD_BLOCK*handle->maxGridSizeX;
int maxNForACall = max(handle->maxGridSizeX, THREAD_BLOCK*handle->maxGridSizeX);
//fprintf(stderr,"Loop on j: %d\n",j);
for (i=0; i<nr; i+=nrws) {
nrws = MIN(maxNForACall, nr - i);
//fprintf(stderr,"cpy_coo_2_hlg: i : %d nrws: %d \n", i,nrws);
CONCAT(GEN_PSI_FUNC_NAME(TYPE_SYMBOL),_)(handle,nrws,i, nr, nza, baseIdx, hacksz, noffs, isz,
rS, hackOffs, devIdisp, devJa, devVal, idiag, rP, cM);
}
}

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE cuFloatComplex
#define TYPE_SYMBOL c
#include "psi_cuda_CopyCooToElg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE cuFloatComplex
#define TYPE_SYMBOL c
#include "psi_cuda_CopyCooToHlg.cuh"

@ -0,0 +1,16 @@
#pragma once
#define PRE_CONCAT(A, B) A ## B
#define CONCAT(A, B) PRE_CONCAT(A, B)
#define MIN(A,B) ( (A)<(B) ? (A) : (B) )
#define SQUARE(x) ((x)*(x))
#define GET_ADDR(a,ix,iy,nc) a[(nc)*(ix)+(iy)]
#define GET_VAL(a,ix,iy,nc) (GET_ADDR(a,ix,iy,nc))
__device__ __host__ static float zero_float() { return 0.0f; }
__device__ __host__ static cuFloatComplex zero_cuFloatComplex() { return make_cuFloatComplex(0.0, 0.0); }
#if (__CUDA_ARCH__ >= 130) || (!__CUDA_ARCH__)
__device__ __host__ static double zero_double() { return 0.0; }
__device__ __host__ static cuDoubleComplex zero_cuDoubleComplex() { return make_cuDoubleComplex(0.0, 0.0); }
#endif

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE double
#define TYPE_SYMBOL d
#include "psi_cuda_CopyCooToElg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE double
#define TYPE_SYMBOL d
#include "psi_cuda_CopyCooToHlg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE float
#define TYPE_SYMBOL s
#include "psi_cuda_CopyCooToElg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE float
#define TYPE_SYMBOL s
#include "psi_cuda_CopyCooToHlg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE cuDoubleComplex
#define TYPE_SYMBOL z
#include "psi_cuda_CopyCooToElg.cuh"

@ -0,0 +1,10 @@
#include <stdlib.h>
#include <stdio.h>
#include "cintrf.h"
#include "vectordev.h"
#define VALUE_TYPE cuDoubleComplex
#define TYPE_SYMBOL z
#include "psi_cuda_CopyCooToHlg.cuh"

@ -0,0 +1,21 @@
(c) Copyright 2011-2021 Davide Barbieri, Salvatore Filippone
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.
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 COPYRIGHT HOLDER OR 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.

@ -0,0 +1,143 @@
include ../Make.inc
#
# Libraries used
#
LIBDIR=../lib
INCDIR=../include
MODDIR=../modules
PSBLAS_LIB= -lpsb_util -lpsb_base
#-lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS)
#
# Compilers and such
#
#CCOPT= -g
FINCLUDES=$(FMFLAG). $(FMFLAG)$(INCDIR) $(FMFLAG)$(MODDIR) $(FIFLAG).
CINCLUDES=$(SPGPU_INCLUDES) $(CUDA_INCLUDES) -I$(INCDIR)
LIBNAME=libpsb_cuda.a
FOBJS=cusparse_mod.o base_cusparse_mod.o \
s_cusparse_mod.o d_cusparse_mod.o c_cusparse_mod.o z_cusparse_mod.o \
psb_vectordev_mod.o core_mod.o \
psb_s_vectordev_mod.o psb_d_vectordev_mod.o psb_i_vectordev_mod.o\
psb_c_vectordev_mod.o psb_z_vectordev_mod.o psb_base_vectordev_mod.o \
elldev_mod.o hlldev_mod.o diagdev_mod.o hdiagdev_mod.o \
psb_i_cuda_vect_mod.o \
psb_d_cuda_vect_mod.o psb_s_cuda_vect_mod.o\
psb_z_cuda_vect_mod.o psb_c_cuda_vect_mod.o\
psb_d_cuda_elg_mat_mod.o psb_d_cuda_hlg_mat_mod.o \
psb_d_cuda_hybg_mat_mod.o psb_d_cuda_csrg_mat_mod.o\
psb_s_cuda_elg_mat_mod.o psb_s_cuda_hlg_mat_mod.o \
psb_s_cuda_hybg_mat_mod.o psb_s_cuda_csrg_mat_mod.o\
psb_c_cuda_elg_mat_mod.o psb_c_cuda_hlg_mat_mod.o \
psb_c_cuda_hybg_mat_mod.o psb_c_cuda_csrg_mat_mod.o\
psb_z_cuda_elg_mat_mod.o psb_z_cuda_hlg_mat_mod.o \
psb_z_cuda_hybg_mat_mod.o psb_z_cuda_csrg_mat_mod.o\
psb_cuda_env_mod.o psb_cuda_mod.o \
psb_d_cuda_diag_mat_mod.o\
psb_d_cuda_hdiag_mat_mod.o psb_s_cuda_hdiag_mat_mod.o\
psb_s_cuda_dnsg_mat_mod.o psb_d_cuda_dnsg_mat_mod.o \
psb_c_cuda_dnsg_mat_mod.o psb_z_cuda_dnsg_mat_mod.o \
dnsdev_mod.o
COBJS= elldev.o hlldev.o diagdev.o hdiagdev.o vectordev.o ivectordev.o dnsdev.o\
svectordev.o dvectordev.o cvectordev.o zvectordev.o cuda_util.o \
fcusparse.o scusparse.o dcusparse.o ccusparse.o zcusparse.o
OBJS=$(COBJS) $(FOBJS)
lib: objs ilib cudalib spgpulib
ar cur $(LIBNAME) $(OBJS)
/bin/cp -p $(LIBNAME) $(LIBDIR)
objs: spgpuinc $(OBJS) iobjs cudaobjs spgpuobjs
/bin/cp -p *$(.mod) $(MODDIR)
/bin/cp -p *.h $(INCDIR)
spgpuinc:
$(MAKE) -C spgpu includes
spgpuobjs:
$(MAKE) -C spgpu objs
spgpulib:
$(MAKE) -C spgpu lib
dnsdev_mod.o hlldev_mod.o elldev_mod.o psb_base_vectordev_mod.o: core_mod.o
psb_d_cuda_vect_mod.o psb_s_cuda_vect_mod.o psb_z_cuda_vect_mod.o psb_c_cuda_vect_mod.o: psb_i_cuda_vect_mod.o
psb_i_cuda_vect_mod.o : psb_vectordev_mod.o psb_cuda_env_mod.o
cusparse_mod.o: s_cusparse_mod.o d_cusparse_mod.o c_cusparse_mod.o z_cusparse_mod.o
s_cusparse_mod.o d_cusparse_mod.o c_cusparse_mod.o z_cusparse_mod.o : base_cusparse_mod.o
psb_d_cuda_hlg_mat_mod.o: hlldev_mod.o psb_d_cuda_vect_mod.o psb_cuda_env_mod.o
psb_d_cuda_elg_mat_mod.o: elldev_mod.o psb_d_cuda_vect_mod.o
psb_d_cuda_diag_mat_mod.o: diagdev_mod.o psb_d_cuda_vect_mod.o
psb_d_cuda_hdiag_mat_mod.o: hdiagdev_mod.o psb_d_cuda_vect_mod.o
psb_s_cuda_dnsg_mat_mod.o: dnsdev_mod.o psb_s_cuda_vect_mod.o
psb_d_cuda_dnsg_mat_mod.o: dnsdev_mod.o psb_d_cuda_vect_mod.o
psb_c_cuda_dnsg_mat_mod.o: dnsdev_mod.o psb_c_cuda_vect_mod.o
psb_z_cuda_dnsg_mat_mod.o: dnsdev_mod.o psb_z_cuda_vect_mod.o
psb_s_cuda_hlg_mat_mod.o: hlldev_mod.o psb_s_cuda_vect_mod.o psb_cuda_env_mod.o
psb_s_cuda_elg_mat_mod.o: elldev_mod.o psb_s_cuda_vect_mod.o
psb_s_cuda_diag_mat_mod.o: diagdev_mod.o psb_s_cuda_vect_mod.o
psb_s_cuda_hdiag_mat_mod.o: hdiagdev_mod.o psb_s_cuda_vect_mod.o
psb_s_cuda_csrg_mat_mod.o psb_s_cuda_hybg_mat_mod.o: cusparse_mod.o psb_vectordev_mod.o
psb_d_cuda_csrg_mat_mod.o psb_d_cuda_hybg_mat_mod.o: cusparse_mod.o psb_vectordev_mod.o
psb_z_cuda_hlg_mat_mod.o: hlldev_mod.o psb_z_cuda_vect_mod.o psb_cuda_env_mod.o
psb_z_cuda_elg_mat_mod.o: elldev_mod.o psb_z_cuda_vect_mod.o
psb_c_cuda_hlg_mat_mod.o: hlldev_mod.o psb_c_cuda_vect_mod.o psb_cuda_env_mod.o
psb_c_cuda_elg_mat_mod.o: elldev_mod.o psb_c_cuda_vect_mod.o
psb_c_cuda_csrg_mat_mod.o psb_c_cuda_hybg_mat_mod.o: cusparse_mod.o psb_vectordev_mod.o
psb_z_cuda_csrg_mat_mod.o psb_z_cuda_hybg_mat_mod.o: cusparse_mod.o psb_vectordev_mod.o
psb_vectordev_mod.o: psb_s_vectordev_mod.o psb_d_vectordev_mod.o psb_c_vectordev_mod.o psb_z_vectordev_mod.o psb_i_vectordev_mod.o
psb_i_vectordev_mod.o psb_s_vectordev_mod.o psb_d_vectordev_mod.o psb_c_vectordev_mod.o psb_z_vectordev_mod.o: psb_base_vectordev_mod.o
vectordev.o: cuda_util.o vectordev.h
elldev.o: elldev.c
dnsdev.o: dnsdev.c
fcusparse.h elldev.c: elldev.h vectordev.h
fcusparse.o scusparse.o dcusparse.o ccusparse.o zcusparse.o : fcusparse.h
fcusparse.o scusparse.o dcusparse.o ccusparse.o zcusparse.o : fcusparse_fct.h
svectordev.o: svectordev.h vectordev.h
dvectordev.o: dvectordev.h vectordev.h
cvectordev.o: cvectordev.h vectordev.h
zvectordev.o: zvectordev.h vectordev.h
psb_cuda_env_mod.o: base_cusparse_mod.o
psb_cuda_mod.o: psb_cuda_env_mod.o psb_i_cuda_vect_mod.o\
psb_d_cuda_vect_mod.o psb_s_cuda_vect_mod.o\
psb_z_cuda_vect_mod.o psb_c_cuda_vect_mod.o\
psb_d_cuda_elg_mat_mod.o psb_d_cuda_hlg_mat_mod.o \
psb_d_cuda_hybg_mat_mod.o psb_d_cuda_csrg_mat_mod.o\
psb_s_cuda_elg_mat_mod.o psb_s_cuda_hlg_mat_mod.o \
psb_s_cuda_hybg_mat_mod.o psb_s_cuda_csrg_mat_mod.o\
psb_c_cuda_elg_mat_mod.o psb_c_cuda_hlg_mat_mod.o \
psb_c_cuda_hybg_mat_mod.o psb_c_cuda_csrg_mat_mod.o\
psb_z_cuda_elg_mat_mod.o psb_z_cuda_hlg_mat_mod.o \
psb_z_cuda_hybg_mat_mod.o psb_z_cuda_csrg_mat_mod.o\
psb_d_cuda_diag_mat_mod.o \
psb_d_cuda_hdiag_mat_mod.o psb_s_cuda_hdiag_mat_mod.o\
psb_s_cuda_dnsg_mat_mod.o psb_d_cuda_dnsg_mat_mod.o \
psb_c_cuda_dnsg_mat_mod.o psb_z_cuda_dnsg_mat_mod.o
iobjs: $(FOBJS)
$(MAKE) -C impl objs
cudaobjs: $(FOBJS)
$(MAKE) -C CUDA objs
ilib: objs
$(MAKE) -C impl lib LIBNAME=$(LIBNAME)
cudalib: objs ilib
$(MAKE) -C CUDA lib LIBNAME=$(LIBNAME)
clean: cclean iclean cudaclean spgpuclean
/bin/rm -f $(FOBJS) *$(.mod) *.a
cclean:
/bin/rm -f $(COBJS)
iclean:
$(MAKE) -C impl clean
cudaclean:
$(MAKE) -C CUDA clean
spgpuclean:
$(MAKE) -C spgpu clean
veryclean: clean

@ -0,0 +1,113 @@
! Parallel Sparse BLAS GPU plugin
! (C) Copyright 2013
!
! Salvatore Filippone
! Alessandro Fanfarillo
!
! 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 base_cusparse_mod
use iso_c_binding
! Interface to CUSPARSE.
enum, bind(c)
enumerator cusparse_status_success
enumerator cusparse_status_not_initialized
enumerator cusparse_status_alloc_failed
enumerator cusparse_status_invalid_value
enumerator cusparse_status_arch_mismatch
enumerator cusparse_status_mapping_error
enumerator cusparse_status_execution_failed
enumerator cusparse_status_internal_error
enumerator cusparse_status_matrix_type_not_supported
end enum
enum, bind(c)
enumerator cusparse_matrix_type_general
enumerator cusparse_matrix_type_symmetric
enumerator cusparse_matrix_type_hermitian
enumerator cusparse_matrix_type_triangular
end enum
enum, bind(c)
enumerator cusparse_fill_mode_lower
enumerator cusparse_fill_mode_upper
end enum
enum, bind(c)
enumerator cusparse_diag_type_non_unit
enumerator cusparse_diag_type_unit
end enum
enum, bind(c)
enumerator cusparse_index_base_zero
enumerator cusparse_index_base_one
end enum
enum, bind(c)
enumerator cusparse_operation_non_transpose
enumerator cusparse_operation_transpose
enumerator cusparse_operation_conjugate_transpose
end enum
enum, bind(c)
enumerator cusparse_direction_row
enumerator cusparse_direction_column
end enum
interface
function FcusparseCreate() &
& bind(c,name="FcusparseCreate") result(res)
use iso_c_binding
integer(c_int) :: res
end function FcusparseCreate
end interface
interface
function FcusparseDestroy() &
& bind(c,name="FcusparseDestroy") result(res)
use iso_c_binding
integer(c_int) :: res
end function FcusparseDestroy
end interface
contains
function initFcusparse() result(res)
implicit none
integer(c_int) :: res
res = FcusparseCreate()
end function initFcusparse
function closeFcusparse() result(res)
implicit none
integer(c_int) :: res
res = FcusparseDestroy()
end function closeFcusparse
end module base_cusparse_mod

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save