From 5abcad9dda12f195f9b6366416ad7f140be29f1e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 11 May 2021 10:05:27 +0200 Subject: [PATCH 01/15] Fix release news --- ReleaseNews | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ReleaseNews b/ReleaseNews index 0b1937e3..558b497c 100644 --- a/ReleaseNews +++ b/ReleaseNews @@ -1,5 +1,8 @@ WHAT'S NEW +Version 3.7.0.1 + 1. PREC%DESCR method now requires a mandatory INFO argument. + Version 3.7.0 1. Major change at API level: integer kinds reorganization. Local indices are now of kind PSB_IPK_, whereas global indices @@ -9,7 +12,7 @@ Version 3.7.0 large as IPK. 2. The internals have also been reorganized heavily, with a much more coherent design and split of functionalities into source - files. + files. Version 3.6.1 From e19c2bf823e4da9260f292de03532fbd4ba9bd8e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 11 May 2021 10:13:29 +0200 Subject: [PATCH 02/15] Restore test files. --- test/kernel/Makefile | 49 + test/kernel/d_file_spmv.f90 | 297 +++ test/kernel/pdgenspmv.f90 | 770 ++++++++ test/kernel/runs/fspmv.inp | 5 + test/kernel/runs/spmv.inp | 3 + test/kernel/s_file_spmv.f90 | 295 +++ test/kernel/vecoperation.f90 | 385 ++++ test/torture/Makefile | 45 + test/torture/psb_c_mvsv_tester.f90 | 2811 +++++++++++++++++++++++++++ test/torture/psb_d_mvsv_tester.f90 | 2812 ++++++++++++++++++++++++++++ test/torture/psb_mvsv_tester.f90 | 6 + test/torture/psb_s_mvsv_tester.f90 | 2809 +++++++++++++++++++++++++++ test/torture/psb_z_mvsv_tester.f90 | 2810 +++++++++++++++++++++++++++ test/torture/psbtf.f90 | 754 ++++++++ 14 files changed, 13851 insertions(+) create mode 100644 test/kernel/Makefile create mode 100644 test/kernel/d_file_spmv.f90 create mode 100644 test/kernel/pdgenspmv.f90 create mode 100644 test/kernel/runs/fspmv.inp create mode 100644 test/kernel/runs/spmv.inp create mode 100644 test/kernel/s_file_spmv.f90 create mode 100644 test/kernel/vecoperation.f90 create mode 100644 test/torture/Makefile create mode 100644 test/torture/psb_c_mvsv_tester.f90 create mode 100644 test/torture/psb_d_mvsv_tester.f90 create mode 100644 test/torture/psb_mvsv_tester.f90 create mode 100644 test/torture/psb_s_mvsv_tester.f90 create mode 100644 test/torture/psb_z_mvsv_tester.f90 create mode 100644 test/torture/psbtf.f90 diff --git a/test/kernel/Makefile b/test/kernel/Makefile new file mode 100644 index 00000000..9dc88e59 --- /dev/null +++ b/test/kernel/Makefile @@ -0,0 +1,49 @@ +# +# Libraries used +# +INSTALLDIR=../.. +INCDIR=$(INSTALLDIR)/include/ +MODDIR=$(INSTALLDIR)/modules/ +include $(INCDIR)/Make.inc.psblas +LIBDIR=$(INSTALLDIR)/lib/ +PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base +LDLIBS=$(PSBLDLIBS) + +FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). + + +DTOBJS=d_file_spmv.o +STOBJS=s_file_spmv.o +DPGOBJS=pdgenspmv.o +DVECOBJS=vecoperation.o +EXEDIR=./runs + +all: runsd d_file_spmv s_file_spmv pdgenspmv vecoperation + +runsd: + (if test ! -d runs ; then mkdir runs; fi) + +d_file_spmv: $(DTOBJS) + $(FLINK) $(LOPT) $(DTOBJS) -o d_file_spmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv d_file_spmv $(EXEDIR) + +pdgenspmv: $(DPGOBJS) + $(FLINK) $(LOPT) $(DPGOBJS) -o pdgenspmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv pdgenspmv $(EXEDIR) + + +s_file_spmv: $(STOBJS) + $(FLINK) $(LOPT) $(STOBJS) -o s_file_spmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv s_file_spmv $(EXEDIR) + +vecoperation: $(DVECOBJS) + $(FLINK) $(LOPT) $(DVECOBJS) -o vecoperation $(PSBLAS_LIB) $(LDLIBS) + /bin/mv vecoperation $(EXEDIR) + +clean: + /bin/rm -f $(DBOBJSS) $(DBOBJS) $(DTOBJS) $(STOBJS) $(DVECOBJS) + +lib: + (cd ../../; make library) +verycleanlib: + (cd ../../; make veryclean) diff --git a/test/kernel/d_file_spmv.f90 b/test/kernel/d_file_spmv.f90 new file mode 100644 index 00000000..40a79982 --- /dev/null +++ b/test/kernel/d_file_spmv.f90 @@ -0,0 +1,297 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +program d_file_spmv + use psb_base_mod + use psb_util_mod + implicit none + + ! input parameters + character(len=40) :: kmethd, ptype + character(len=512) :: mtrx_file, rhs_file + + ! sparse matrices + type(psb_dspmat_type) :: a + type(psb_ldspmat_type) :: aux_a + + ! dense matrices + real(psb_dpk_), allocatable, target :: aux_b(:,:), d(:) + real(psb_dpk_), allocatable , save :: x_col_glob(:), r_col_glob(:) + real(psb_dpk_), pointer :: b_col_glob(:) + type(psb_d_vect_type) :: b_col, x_col, r_col + + + ! communications data structure + type(psb_desc_type):: desc_a + + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + + ! solver paramters + integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst, nr + integer(psb_lpk_) :: lnp + integer(psb_epk_) :: amatsize, descsize, annz, nbytes + real(psb_dpk_) :: err, eps,cond + + character(len=5) :: afmt + character(len=20) :: name + character(len=2) :: filefmt + integer(psb_ipk_), parameter :: iunit=12 + integer(psb_ipk_), parameter :: times=20 + integer(psb_ipk_) :: iparm(20) + + ! other variables + integer(psb_lpk_) :: i,j,m_problem + integer(psb_ipk_) :: internal, m,ii,nnzero, info + real(psb_dpk_) :: t1, t2, r_amax, b_amax,& + &scale,resmx,resmxp, flops, bdwdth + real(psb_dpk_) :: tt1, tt2, tflops + integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne + integer(psb_ipk_), allocatable :: ivg(:), ipv(:) + + + call psb_init(ctxt) + call psb_info(ctxt,iam,np) + lnp = np + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ctxt) + stop + endif + + + name='d_file_spmv' + if(psb_get_errstatus() /= 0) goto 9999 + info=psb_success_ + call psb_set_errverbosity(2) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + read(psb_inp_unit,*) mtrx_file + read(psb_inp_unit,*) filefmt + read(psb_inp_unit,*) ipart + end if + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,ipart) + rhs_file = 'NONE' + afmt = 'CSR' + call psb_barrier(ctxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + select case(psb_toupper(filefmt)) + case('MM') + ! For Matrix Market we have an input file for the matrix + ! and an (optional) second file for the RHS. + call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) + if (info == psb_success_) then + if (rhs_file /= 'NONE') then + call mm_array_read(aux_b,info,iunit=iunit,filename=rhs_file) + end if + end if + + case ('HB') + ! For Harwell-Boeing we have a single file which may or may not + ! contain an RHS. + call hb_read(aux_a,info,iunit=iunit,b=aux_b,filename=mtrx_file) + + case default + info = -1 + write(psb_err_unit,*) 'Wrong choice for fileformat ', filefmt + end select + if (info /= psb_success_) then + write(psb_err_unit,*) 'Error while reading input matrix ' + call psb_abort(ctxt) + end if + + m_problem = aux_a%get_nrows() + call psb_bcast(ctxt,m_problem) + + ! At this point aux_b may still be unallocated + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(psb_err_unit,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(psb_out_unit,'("Generating an rhs...")') + write(psb_out_unit,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.d0 + enddo + endif + + else + + call psb_bcast(ctxt,m_problem) + b_col_glob =>aux_b(:,1) + + end if + + ! switch over different partition types + write(psb_out_unit,'("Number of processors : ",i0)')np + if (ipart == 0) then + call psb_barrier(ctxt) + if (iam==psb_root_) write(psb_out_unit,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) + + else if (ipart == 2) then + if (iam==psb_root_) then + write(psb_out_unit,'("Partition type: graph")') + write(psb_out_unit,'(" ")') + ! write(psb_err_unit,'("Build type: graph")') + call build_mtpart(aux_a,lnp) + + endif + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,vg=ivg) + + else + if (iam==psb_root_) write(psb_out_unit,'("Partition type: default block")') + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,parts=part_block) + end if + + + call psb_geall(x_col,desc_a,info) + call x_col%set(done) + call psb_geasb(x_col,desc_a,info) + call psb_geall(b_col,desc_a,info) + call x_col%zero() + call psb_geasb(b_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ctxt, t2) + + if (iam==psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2 + write(psb_out_unit,'(" ")') + end if + + + call psb_barrier(ctxt) + t1 = psb_wtime() + do i=1,times + call psb_spmm(done,a,x_col,dzero,b_col,desc_a,info,'n') + end do + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + call psb_amx(ctxt,t2) + + ! FIXME: cache flush needed here + call psb_barrier(ctxt) + tt1 = psb_wtime() + do i=1,times + call psb_spmm(done,a,x_col,dzero,b_col,desc_a,info,'t') + end do + call psb_barrier(ctxt) + tt2 = psb_wtime() - tt1 + call psb_amx(ctxt,tt2) + + nr = desc_a%get_global_rows() + annz = a%get_nzeros() + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + + if (iam==psb_root_) then + flops = 2.d0*times*annz + tflops=flops + write(psb_out_unit,'("Matrix: ",a)') mtrx_file + write(psb_out_unit,'("Test on : ",i20," processors")') np + write(psb_out_unit,'("Size of matrix : ",i20," ")') nr + write(psb_out_unit,'("Number of nonzeros : ",i20," ")') annz + write(psb_out_unit,'("Memory occupation : ",i20," ")') amatsize + write(psb_out_unit,'("Number of flops (",i0," prod) : ",F20.0," ")') times,flops + flops = flops / (t2) + tflops = tflops / (tt2) + write(psb_out_unit,'("Time for ",i0," products (s) : ",F20.3)')times, t2 + write(psb_out_unit,'("Time per product (ms) : ",F20.3)') t2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS : ",F20.3)') flops/1.d6 + + write(psb_out_unit,'("Time for ",i0," products (s) (trans.): ",F20.3)') times,tt2 + write(psb_out_unit,'("Time per product (ms) (trans.): ",F20.3)') tt2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS (trans.): ",F20.3)') tflops/1.d6 + + ! + ! This computation is valid for CSR + ! + nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_ip)+& + & annz*(psb_sizeof_dp + psb_sizeof_ip) + bdwdth = times*nbytes/(t2*1.d6) + write(psb_out_unit,*) + write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth + bdwdth = times*nbytes/(tt2*1.d6) + write(psb_out_unit,'("MBYTES/S (trans): ",F20.3)') bdwdth + write(psb_out_unit,'("Storage type for DESC_A: ",a)') desc_a%get_fmt() + + end if + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call psb_cdfree(desc_a,info) + call psb_exit(ctxt) + stop + +9999 call psb_error(ctxt) + + stop + +end program d_file_spmv + + + + + diff --git a/test/kernel/pdgenspmv.f90 b/test/kernel/pdgenspmv.f90 new file mode 100644 index 00000000..e96736a8 --- /dev/null +++ b/test/kernel/pdgenspmv.f90 @@ -0,0 +1,770 @@ +! +! Parallel Sparse BLAS version 3.5.1 +! (C) Copyright 2015 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +! File: ppde.f90 +! +module psb_d_pde3d_mod + + + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_lpk_, psb_desc_type,& + & psb_dspmat_type, psb_d_vect_type, dzero,& + & psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_i_base_vect_type, psb_l_base_vect_type + + interface + function d_func_3d(x,y,z) result(val) + import :: psb_dpk_ + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + end function d_func_3d + end interface + + interface psb_gen_pde3d + module procedure psb_d_gen_pde3d + end interface psb_gen_pde3d + +contains + + function d_null_func_3d(x,y,z) result(val) + + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + + val = dzero + + end function d_null_func_3d + ! + ! functions parametrizing the differential equation + ! + + ! + ! Note: b1, b2 and b3 are the coefficients of the first + ! derivative of the unknown function. The default + ! we apply here is to have them zero, so that the resulting + ! matrix is symmetric/hermitian and suitable for + ! testing with CG and FCG. + ! When testing methods for non-hermitian matrices you can + ! change the B1/B2/B3 functions to e.g. done/sqrt((3*done)) + ! + function b1(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b1 + real(psb_dpk_), intent(in) :: x,y,z + b1=dzero + end function b1 + function b2(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b2 + real(psb_dpk_), intent(in) :: x,y,z + b2=dzero + end function b2 + function b3(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: b3 + real(psb_dpk_), intent(in) :: x,y,z + b3=dzero + end function b3 + function c(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: c + real(psb_dpk_), intent(in) :: x,y,z + c=dzero + end function c + function a1(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a1 + real(psb_dpk_), intent(in) :: x,y,z + a1=done/80 + end function a1 + function a2(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a2 + real(psb_dpk_), intent(in) :: x,y,z + a2=done/80 + end function a2 + function a3(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: a3 + real(psb_dpk_), intent(in) :: x,y,z + a3=done/80 + end function a3 + function g(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + implicit none + real(psb_dpk_) :: g + real(psb_dpk_), intent(in) :: x,y,z + g = dzero + if (x == done) then + g = done + else if (x == dzero) then + g = exp(y**2-z**2) + end if + end function g + + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& + & f,amold,vmold,imold,partition,nrl,iv) + use psb_base_mod + use psb_util_mod + ! + ! Discretizes the partial differential equation + ! + ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) + ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f + ! dxdx dydy dzdz dx dy dz + ! + ! with Dirichlet boundary conditions + ! u = g + ! + ! on the unit cube 0<=x,y,z<=1. + ! + ! + ! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. + ! + implicit none + integer(psb_ipk_) :: idim + type(psb_dspmat_type) :: a + type(psb_d_vect_type) :: xv,bv + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info + character(len=*) :: afmt + procedure(d_func_3d), optional :: f + class(psb_d_base_sparse_mat), optional :: amold + class(psb_d_base_vect_type), optional :: vmold + class(psb_i_base_vect_type), optional :: imold + integer(psb_ipk_), optional :: partition, nrl,iv(:) + + ! Local variables. + + integer(psb_ipk_), parameter :: nb=20 + type(psb_d_csc_sparse_mat) :: acsc + type(psb_d_coo_sparse_mat) :: acoo + type(psb_d_csr_sparse_mat) :: acsr + real(psb_dpk_) :: zt(nb),x,y,z + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_lpk_) :: m,n,glob_row,nt + integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner + ! For 3D partition + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(3), npp, minfo + integer(psb_ipk_) :: npx,npy,npz, iamx,iamy,iamz,mynx,myny,mynz + integer(psb_ipk_), allocatable :: bndx(:),bndy(:),bndz(:) + ! Process grid + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: icoeff + integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) + real(psb_dpk_), allocatable :: val(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_dpk_) :: deltah, sqdeltah, deltah2 + real(psb_dpk_), parameter :: rhs=dzero,one=done,zero=dzero + real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen, tcdasb + integer(psb_ipk_) :: err_act + procedure(d_func_3d), pointer :: f_ + character(len=20) :: name, ch_err,tmpfmt + + info = psb_success_ + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ctxt, iam, np) + + + if (present(f)) then + f_ => f + else + f_ => d_null_func_3d + end if + + deltah = done/(idim+1) + sqdeltah = deltah*deltah + deltah2 = (2*done)* deltah + + if (present(partition)) then + if ((1<= partition).and.(partition <= 3)) then + partition_ = partition + else + write(*,*) 'Invalid partition choice ',partition,' defaulting to 3' + partition_ = 3 + end if + else + partition_ = 3 + end if + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = (1_psb_lpk_*idim)*idim*idim + n = m + nnz = ((n*7)/(np)) + if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n + t0 = psb_wtime() + select case(partition_) + case(1) + ! A BLOCK partition + if (present(nrl)) then + nr = nrl + else + ! + ! Using a simple BLOCK distribution. + ! + nt = (m+np-1)/np + nr = max(0,min(nt,m-(iam*nt))) + end if + + nt = nr + call psb_sum(ctxt,nt) + if (nt /= m) then + write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + + ! + ! First example of use of CDALL: specify for each process a number of + ! contiguous rows + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(2) + ! A partition defined by the user through IV + + if (present(iv)) then + if (size(iv) /= m) then + write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + else + write(psb_err_unit,*) iam, 'Initialization error: IV not present' + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + + ! + ! Second example of use of CDALL: specify for each row the + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(3) + ! A 3-dimensional partition + + ! A nifty MPI function will split the process list + npdims = 0 + call mpi_dims_create(np,3,npdims,info) + npx = npdims(1) + npy = npdims(2) + npz = npdims(3) + + allocate(bndx(0:npx),bndy(0:npy),bndz(0:npz)) + ! We can reuse idx2ijk for process indices as well. + call idx2ijk(iamx,iamy,iamz,iam,npx,npy,npz,base=0) + ! Now let's split the 3D cube in hexahedra + call dist1Didx(bndx,idim,npx) + mynx = bndx(iamx+1)-bndx(iamx) + call dist1Didx(bndy,idim,npy) + myny = bndy(iamy+1)-bndy(iamy) + call dist1Didx(bndz,idim,npz) + mynz = bndz(iamz+1)-bndz(iamz) + + ! How many indices do I own? + nlr = mynx*myny*mynz + allocate(myidx(nlr)) + ! Now, let's generate the list of indices I own + nr = 0 + do i=bndx(iamx),bndx(iamx+1)-1 + do j=bndy(iamy),bndy(iamy+1)-1 + do k=bndz(iamz),bndz(iamz+1)-1 + nr = nr + 1 + call ijk2idx(myidx(nr),i,j,k,idim,idim,idim) + end do + end do + end do + if (nr /= nlr) then + write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& + & nr,nlr,mynx,myny,mynz + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + end if + + ! + ! Third example of use of CDALL: specify for each process + ! the set of global indices it owns. + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) + + case default + write(psb_err_unit,*) iam, 'Initialization error: should not get here' + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end select + + + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + if (info == psb_success_) call psb_geall(xv,desc_a,info) + if (info == psb_success_) call psb_geall(bv,desc_a,info) + + call psb_barrier(ctxt) + talc = psb_wtime()-t0 + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! loop over rows belonging to current process in a block + ! distribution. + + call psb_barrier(ctxt) + t1 = psb_wtime() + do ii=1, nlr,nb + ib = min(nb,nlr-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) + ! x, y, z coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + z = (iz-1)*deltah + zt(k) = f_(x,y,z) + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 + if (ix == 1) then + zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1,z) + val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 + if (iy == 1) then + zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y,z-1) + val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 + if (iz == 1) then + zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + ! term depending on (x,y,z) + val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & + & + c(x,y,z) + call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + ! term depending on (x,y,z+1) + val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 + if (iz == idim) then + zt(k) = g(x,y,done)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y+1,z) + val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 + if (iy == idim) then + zt(k) = g(x,done,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x+1,y,z) + val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 + if (ix==idim) then + zt(k) = g(done,y,z)*(-val(icoeff)) + zt(k) + else + call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + end do + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) exit + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) exit + zt(:)=dzero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) exit + end do + + tgen = psb_wtime()-t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='insert rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(val,irow,icol) + + call psb_barrier(ctxt) + t1 = psb_wtime() + call psb_cdasb(desc_a,info,mold=imold) + tcdasb = psb_wtime()-t1 + call psb_barrier(ctxt) + t1 = psb_wtime() + if (info == psb_success_) then + if (present(amold)) then + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) + else + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + end if + end if + call psb_barrier(ctxt) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) + if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tasb = psb_wtime()-t1 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 + + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) + if(iam == psb_root_) then + tmpfmt = a%get_fmt() + write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& + & tmpfmt + write(psb_out_unit,'("-allocation time : ",es12.5)') talc + write(psb_out_unit,'("-coeff. gen. time : ",es12.5)') tgen + write(psb_out_unit,'("-desc asbly time : ",es12.5)') tcdasb + write(psb_out_unit,'("- mat asbly time : ",es12.5)') tasb + write(psb_out_unit,'("-total time : ",es12.5)') ttot + + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psb_d_gen_pde3d + + +end module psb_d_pde3d_mod + +program pdgenspmv + use psb_base_mod + use psb_util_mod + use psb_d_pde3d_mod + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer(psb_ipk_) :: idim + + ! miscellaneous + real(psb_dpk_), parameter :: one = done + real(psb_dpk_) :: t1, t2, tprec, flops, tflops, tt1, tt2, bdwdth + + ! sparse matrix and preconditioner + type(psb_dspmat_type) :: a + ! descriptor + type(psb_desc_type) :: desc_a + ! dense matrices + type(psb_d_vect_type) :: xv,bv, vtst + real(psb_dpk_), allocatable :: tst(:) + ! blacs parameters + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + + ! solver parameters + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, nr, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size, annz, nbytes + real(psb_dpk_) :: err, eps + integer(psb_ipk_), parameter :: times=10 + + ! other variables + integer(psb_ipk_) :: info, i + character(len=20) :: name,ch_err + character(len=40) :: fname + + info=psb_success_ + + + call psb_init(ctxt) + call psb_info(ctxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ctxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(itwo) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if + ! + ! get parameters + ! + call get_parms(ctxt,afmt,idim) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + call psb_barrier(ctxt) + t1 = psb_wtime() + call psb_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info) + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_gen_pde3d' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (iam == psb_root_) write(psb_out_unit,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) write(psb_out_unit,'(" ")') + + call xv%set(done) + + call psb_barrier(ctxt) + t1 = psb_wtime() + ! + ! Perform Ax multiple times to compute average performance + ! + do i=1,times + call psb_spmm(done,a,xv,dzero,bv,desc_a,info,'n') + end do + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + call psb_amx(ctxt,t2) + + ! FIXME: cache flush needed here + call psb_barrier(ctxt) + tt1 = psb_wtime() + ! + ! Perform A^Tx multiple times to compute average performance + ! + do i=1,times + call psb_spmm(done,a,xv,dzero,bv,desc_a,info,'t') + end do + call psb_barrier(ctxt) + tt2 = psb_wtime() - tt1 + call psb_amx(ctxt,tt2) + + call psb_amx(ctxt,t2) + nr = desc_a%get_global_rows() + annz = a%get_nzeros() + amatsize = a%sizeof() + descsize = psb_sizeof(desc_a) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + + if (iam == psb_root_) then + flops = 2.d0*times*annz + tflops=flops + write(psb_out_unit,'("Matrix: ell1 ",i0)') idim + write(psb_out_unit,'("Test on : ",i20," processors")') np + write(psb_out_unit,'("Size of matrix : ",i20," ")') nr + write(psb_out_unit,'("Number of nonzeros : ",i20," ")') annz + write(psb_out_unit,'("Memory occupation : ",i20," ")') amatsize + write(psb_out_unit,'("Number of flops (",i0," prod) : ",F20.0," ")') times,flops + flops = flops / (t2) + tflops = tflops / (tt2) + write(psb_out_unit,'("Time for ",i0," products (s) : ",F20.3)')times, t2 + write(psb_out_unit,'("Time per product (ms) : ",F20.3)') t2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS : ",F20.3)') flops/1.d6 + + write(psb_out_unit,'("Time for ",i0," products (s) (trans.): ",F20.3)') times,tt2 + write(psb_out_unit,'("Time per product (ms) (trans.): ",F20.3)') tt2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS (trans.): ",F20.3)') tflops/1.d6 + + ! + ! This computation is valid for CSR + ! + nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_ip)+& + & annz*(psb_sizeof_dp + psb_sizeof_ip) + bdwdth = times*nbytes/(t2*1.d6) + write(psb_out_unit,*) + write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth + bdwdth = times*nbytes/(tt2*1.d6) + write(psb_out_unit,'("MBYTES/S (trans): ",F20.3)') bdwdth + write(psb_out_unit,'("Storage type for DESC_A: ",a)') desc_a%get_fmt() + write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize + + end if + + + ! + ! cleanup storage and exit + ! + call psb_gefree(bv,desc_a,info) + call psb_gefree(xv,desc_a,info) + call psb_spfree(a,desc_a,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_exit(ctxt) + stop + +9999 call psb_error(ctxt) + + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ctxt,afmt,idim) + type(psb_ctxt_type) :: ctxt + character(len=*) :: afmt + integer(psb_ipk_) :: idim + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: intbuf(10), ip + + call psb_info(ctxt, iam, np) + + if (iam == 0) then + read(psb_inp_unit,*) afmt + read(psb_inp_unit,*) idim + endif + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,idim) + + if (iam == 0) then + write(psb_out_unit,'("Testing matrix : ell1")') + write(psb_out_unit,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(psb_out_unit,'("Number of processors : ",i0)')np + write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'(" ")') + end if + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer(psb_ipk_) :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage +end program pdgenspmv diff --git a/test/kernel/runs/fspmv.inp b/test/kernel/runs/fspmv.inp new file mode 100644 index 00000000..bd98c266 --- /dev/null +++ b/test/kernel/runs/fspmv.inp @@ -0,0 +1,5 @@ +pde100.mtx +MM +0 + + diff --git a/test/kernel/runs/spmv.inp b/test/kernel/runs/spmv.inp new file mode 100644 index 00000000..91844ce2 --- /dev/null +++ b/test/kernel/runs/spmv.inp @@ -0,0 +1,3 @@ +CSR +50 + diff --git a/test/kernel/s_file_spmv.f90 b/test/kernel/s_file_spmv.f90 new file mode 100644 index 00000000..ebbb85cd --- /dev/null +++ b/test/kernel/s_file_spmv.f90 @@ -0,0 +1,295 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +program s_file_spmv + use psb_base_mod + use psb_util_mod + implicit none + + ! input parameters + character(len=40) :: kmethd, ptype, mtrx_file, rhs_file + + ! sparse matrices + type(psb_sspmat_type) :: a + type(psb_lsspmat_type) :: aux_a + + ! dense matrices + real(psb_spk_), allocatable, target :: aux_b(:,:), d(:) + real(psb_spk_), allocatable , save :: x_col_glob(:), r_col_glob(:) + real(psb_spk_), pointer :: b_col_glob(:) + type(psb_s_vect_type) :: b_col, x_col, r_col + + + ! communications data structure + type(psb_desc_type):: desc_a + + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + + ! solver paramters + integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst, nr + integer(psb_lpk_) :: lnp + integer(psb_epk_) :: amatsize, descsize, annz, nbytes + real(psb_spk_) :: err, eps,cond + + character(len=5) :: afmt + character(len=20) :: name + character(len=2) :: filefmt + integer(psb_ipk_), parameter :: iunit=12 + integer(psb_ipk_), parameter :: times=20 + integer(psb_ipk_) :: iparm(20) + + ! other variables + integer(psb_lpk_) :: i,j,m_problem + integer(psb_ipk_) :: internal, m,ii,nnzero,info + real(psb_dpk_) :: t1, t2, r_amax, b_amax,& + &scale,resmx,resmxp, flops, bdwdth + real(psb_dpk_) :: tt1, tt2, tflops + integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne + integer(psb_ipk_), allocatable :: ivg(:), ipv(:) + + + call psb_init(ctxt) + call psb_info(ctxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ctxt) + stop + endif + + + name='s_file_spmv' + if(psb_get_errstatus() /= 0) goto 9999 + info=psb_success_ + call psb_set_errverbosity(2) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + read(psb_inp_unit,*) mtrx_file + read(psb_inp_unit,*) filefmt + read(psb_inp_unit,*) ipart + end if + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,ipart) + rhs_file = 'NONE' + afmt = 'CSR' + call psb_barrier(ctxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + select case(psb_toupper(filefmt)) + case('MM') + ! For Matrix Market we have an input file for the matrix + ! and an (optional) second file for the RHS. + call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) + if (info == psb_success_) then + if (rhs_file /= 'NONE') then + call mm_array_read(aux_b,info,iunit=iunit,filename=rhs_file) + end if + end if + + case ('HB') + ! For Harwell-Boeing we have a single file which may or may not + ! contain an RHS. + call hb_read(aux_a,info,iunit=iunit,b=aux_b,filename=mtrx_file) + + case default + info = -1 + write(psb_err_unit,*) 'Wrong choice for fileformat ', filefmt + end select + if (info /= psb_success_) then + write(psb_err_unit,*) 'Error while reading input matrix ' + call psb_abort(ctxt) + end if + + m_problem = aux_a%get_nrows() + call psb_bcast(ctxt,m_problem) + + ! At this point aux_b may still be unallocated + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(psb_err_unit,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(psb_out_unit,'("Generating an rhs...")') + write(psb_out_unit,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.d0 + enddo + endif + + else + + call psb_bcast(ctxt,m_problem) + b_col_glob =>aux_b(:,1) + + end if + + ! switch over different partition types + write(psb_out_unit,'("Number of processors : ",i0)')np + if (ipart == 0) then + call psb_barrier(ctxt) + if (iam==psb_root_) write(psb_out_unit,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) + + else if (ipart == 2) then + if (iam==psb_root_) then + write(psb_out_unit,'("Partition type: graph")') + write(psb_out_unit,'(" ")') + ! write(psb_err_unit,'("Build type: graph")') + call build_mtpart(aux_a,lnp) + + endif + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,vg=ivg) + + else + if (iam==psb_root_) write(psb_out_unit,'("Partition type: default block")') + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,parts=part_block) + end if + + call psb_geall(x_col,desc_a,info) + call x_col%set(sone) + call psb_geasb(x_col,desc_a,info) + call psb_geall(b_col,desc_a,info) + call x_col%zero() + call psb_geasb(b_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ctxt, t2) + + if (iam==psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2 + write(psb_out_unit,'(" ")') + end if + + + call psb_barrier(ctxt) + t1 = psb_wtime() + do i=1,times + call psb_spmm(sone,a,x_col,szero,b_col,desc_a,info,'n') + end do + call psb_barrier(ctxt) + t2 = psb_wtime() - t1 + call psb_amx(ctxt,t2) + + ! FIXME: cache flush needed here + call psb_barrier(ctxt) + tt1 = psb_wtime() + do i=1,times + call psb_spmm(sone,a,x_col,szero,b_col,desc_a,info,'t') + end do + call psb_barrier(ctxt) + tt2 = psb_wtime() - tt1 + call psb_amx(ctxt,tt2) + + nr = desc_a%get_global_rows() + annz = a%get_nzeros() + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + + if (iam==psb_root_) then + flops = 2.d0*times*annz + tflops=flops + write(psb_out_unit,'("Matrix: ",a)') mtrx_file + write(psb_out_unit,'("Test on : ",i20," processors")') np + write(psb_out_unit,'("Size of matrix : ",i20," ")') nr + write(psb_out_unit,'("Number of nonzeros : ",i20," ")') annz + write(psb_out_unit,'("Memory occupation : ",i20," ")') amatsize + write(psb_out_unit,'("Number of flops (",i0," prod) : ",F20.0," ")') times,flops + flops = flops / (t2) + tflops = tflops / (tt2) + write(psb_out_unit,'("Time for ",i0," products (s) : ",F20.3)')times, t2 + write(psb_out_unit,'("Time per product (ms) : ",F20.3)') t2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS : ",F20.3)') flops/1.d6 + + write(psb_out_unit,'("Time for ",i0," products (s) (trans.): ",F20.3)') times,tt2 + write(psb_out_unit,'("Time per product (ms) (trans.): ",F20.3)') tt2*1.d3/(1.d0*times) + write(psb_out_unit,'("MFLOPS (trans.): ",F20.3)') tflops/1.d6 + + ! + ! This computation is valid for CSR + ! + nbytes = nr*(2*psb_sizeof_sp + psb_sizeof_ip)+ & + & annz*(psb_sizeof_sp + psb_sizeof_ip) + bdwdth = times*nbytes/(t2*1.d6) + write(psb_out_unit,*) + write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth + bdwdth = times*nbytes/(tt2*1.d6) + write(psb_out_unit,'("MBYTES/S (trans): ",F20.3)') bdwdth + + end if + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call psb_cdfree(desc_a,info) + + call psb_exit(ctxt) + stop + +9999 call psb_error(ctxt) + + stop + +end program s_file_spmv + + + + + diff --git a/test/kernel/vecoperation.f90 b/test/kernel/vecoperation.f90 new file mode 100644 index 00000000..3860a3c3 --- /dev/null +++ b/test/kernel/vecoperation.f90 @@ -0,0 +1,385 @@ +! +! Parallel Sparse BLAS version 3.5.1 +! (C) Copyright 2015 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +! File: vecoperation.f90 +! +module unittestvector_mod + + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,& + & psb_dspmat_type, psb_d_vect_type, dzero, psb_ctxt_type,& + & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type + + interface psb_gen_const + module procedure psb_d_gen_const + end interface psb_gen_const + +contains + + function psb_check_ans(v,val,ctxt) result(ans) + use psb_base_mod + + implicit none + + type(psb_d_vect_type) :: v + real(psb_dpk_) :: val + type(psb_ctxt_type) :: ctxt + logical :: ans + + ! Local variables + integer(psb_ipk_) :: np, iam, info + real(psb_dpk_) :: check + real(psb_dpk_), allocatable :: va(:) + + call psb_info(ctxt,iam,np) + + va = v%get_vect() + va = va - val; + + check = maxval(va); + + call psb_sum(ctxt,check) + + if(check == 0.d0) then + ans = .true. + else + ans = .false. + end if + + end function psb_check_ans + ! + ! subroutine to fill a vector with constant entries + ! + subroutine psb_d_gen_const(v,val,idim,ctxt,desc_a,info) + use psb_base_mod + implicit none + + type(psb_d_vect_type) :: v + type(psb_desc_type) :: desc_a + integer(psb_lpk_) :: idim + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info + real(psb_dpk_) :: val + + ! Local variables + integer(psb_ipk_), parameter :: nb=20 + real(psb_dpk_) :: zt(nb) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: np, iam, nr, nt + integer(psb_ipk_) :: n,nlr,ib,ii + integer(psb_ipk_) :: err_act + integer(psb_lpk_), allocatable :: myidx(:) + + + info = psb_success_ + name = 'create_constant_vector' + call psb_erractionsave(err_act) + + call psb_info(ctxt, iam, np) + + n = idim*np ! The global dimension is the number of process times + ! the input size + + ! We use a simple minded block distribution + nt = (n+np-1)/np + nr = max(0,min(nt,n-(iam*nt))) + nt = nr + + call psb_sum(ctxt,nt) + if (nt /= n) then + write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,n + info = -1 + call psb_barrier(ctxt) + call psb_abort(ctxt) + return + end if + ! Allocate the descriptor with simple minded data distribution + call psb_cdall(ctxt,desc_a,info,nl=nr) + ! Allocate the vector on the recently build descriptor + if (info == psb_success_) call psb_geall(v,desc_a,info) + ! Check that allocation has gone good + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + do ii=1,nlr,nb + ib = min(nb,nlr-ii+1) + zt(:) = val + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),v,desc_a,info) + if(info /= psb_success_) exit + end do + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='insert rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! Assembly of communicator and vector + call psb_cdasb(desc_a,info) + if (info == psb_success_) call psb_geasb(v,desc_a,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psb_d_gen_const + +end module unittestvector_mod + + +program vecoperation + use psb_base_mod + use psb_util_mod + use unittestvector_mod + implicit none + + ! input parameters + integer(psb_lpk_) :: idim = 100 + + ! miscellaneous + real(psb_dpk_), parameter :: one = 1.d0 + real(psb_dpk_), parameter :: two = 2.d0 + real(psb_dpk_), parameter :: onehalf = 0.5_psb_dpk_ + real(psb_dpk_), parameter :: negativeone = -1.d0 + real(psb_dpk_), parameter :: negativetwo = -2.d0 + real(psb_dpk_), parameter :: negativeonehalf = -0.5_psb_dpk_ + ! descriptor + type(psb_desc_type) :: desc_a + ! vector + type(psb_d_vect_type) :: x,y,z + ! blacs parameters + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + ! auxiliary parameters + integer(psb_ipk_) :: info + character(len=20) :: name,ch_err,readinput + real(psb_dpk_) :: ans + logical :: hasitnotfailed + integer(psb_lpk_), allocatable :: myidx(:) + integer(psb_ipk_) :: ib = 1 + real(psb_dpk_) :: zt(1) + + info=psb_success_ + call psb_init(ctxt) + call psb_info(ctxt,iam,np) + + if (iam < 0) then + call psb_exit(ctxt) ! This should not happen, but just in case + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='vecoperation' + call psb_set_errverbosity(itwo) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if + + call get_command_argument(1,readinput) + if (len_trim(readinput) /= 0) read(readinput,*)idim + + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Local vector size",I10)')idim + if (iam == psb_root_) write(psb_out_unit,'("Global vector size",I10)')np*idim + + ! + ! Test of standard vector operation + ! + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Standard Vector Operations")') + if (iam == psb_root_) write(psb_out_unit,'(" ")') + ! X = 1 + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + hasitnotfailed = psb_check_ans(x,one,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Constant vector ")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Constant vector ")') + end if + ! X = 1 , Y = -2, Y = X + Y = 1 -2 = -1 + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ctxt,desc_a,info) + call psb_geaxpby(one,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = X + Y ")') + end if + ! X = 1 , Y = 2, Y = -X + Y = -1 +2 = 1 + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ctxt,desc_a,info) + call psb_geaxpby(negativeone,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,one,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = -X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = -X + Y ")') + end if + ! X = 2 , Y = -2, Y = 0.5*X + Y = 1 - 2 = -1 + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ctxt,desc_a,info) + call psb_geaxpby(onehalf,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = 0.5 X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = 0.5 X + Y ")') + end if + ! X = -2 , Y = 1, Z = 0, Z = X + Y = -2 + 1 = -1 + call psb_d_gen_const(x,negativetwo,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geaxpby(one,x,one,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X + Y ")') + end if + ! X = 2 , Y = 1, Z = 0, Z = X - Y = 2 - 1 = 1 + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geaxpby(one,x,negativeone,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,one,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X - Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X - Y ")') + end if + ! X = 2 , Y = 1, Z = 0, Z = -X + Y = -2 + 1 = -1 + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geaxpby(negativeone,x,one,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = -X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = -X + Y ")') + end if + ! X = 2 , Y = -0.5, Z = 0, Z = X*Y = 2*(-0.5) = -1 + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativeonehalf,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_gemlt(one,x,y,dzero,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> mlt Z = X*Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- mlt Z = X*Y ")') + end if + ! X = 1 , Y = 2, Z = 0, Z = X/Y = 1/2 = 0.5 + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_gediv(x,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,onehalf,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> div Z = X/Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- div Z = X/Y ")') + end if + ! X = -1 , Z = 0, Z = |X| = |-1| = 1 + call psb_d_gen_const(x,negativeone,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geabs(x,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,one,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> abs Z = |X|")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- abs Z = |X| ")') + end if + ! X = 2 , Z = 0, Z = 1/X = 1/2 = 0.5 + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geinv(x,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,onehalf,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> inv Z = 1/X")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- inv Z = 1/X ")') + end if + ! X = 1, Z = 0, c = -2, Z = X + c = -1 + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) + call psb_geaddconst(x,negativetwo,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Add constant Z = X + c")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Add constant Z = X + c")') + end if + + ! + ! Vector to field operation + ! + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Vector to Field Operations")') + if (iam == psb_root_) write(psb_out_unit,'(" ")') + + ! Dot product + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,onehalf,idim,ctxt,desc_a,info) + ans = psb_gedot(x,y,desc_a,info) + if (iam == psb_root_) then + if(ans == np*idim) write(psb_out_unit,'("TEST PASSED >>> Dot product")') + if(ans /= np*idim) write(psb_out_unit,'("TEST FAILED --- Dot product")') + end if + ! MaxNorm + call psb_d_gen_const(x,negativeonehalf,idim,ctxt,desc_a,info) + ans = psb_geamax(x,desc_a,info) + if (iam == psb_root_) then + if(ans == onehalf) write(psb_out_unit,'("TEST PASSED >>> MaxNorm")') + if(ans /= onehalf) write(psb_out_unit,'("TEST FAILED --- MaxNorm")') + end if + + call psb_gefree(x,desc_a,info) + call psb_gefree(y,desc_a,info) + call psb_gefree(z,desc_a,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + call psb_exit(ctxt) + stop + +9999 call psb_error(ctxt) + + stop +end program vecoperation diff --git a/test/torture/Makefile b/test/torture/Makefile new file mode 100644 index 00000000..8a98657e --- /dev/null +++ b/test/torture/Makefile @@ -0,0 +1,45 @@ +INSTALLDIR=../.. +INCDIR=$(INSTALLDIR)/include/ +MODDIR=$(INSTALLDIR)/modules/ +include $(INCDIR)/Make.inc.psblas +LIBDIR=$(INSTALLDIR)/lib/ +PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base +LDLIBS=$(PSBLDLIBS) +CCOPT= -g +FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). + +PSBTOBJS=psbtf.o psb_mvsv_tester.o \ + psb_s_mvsv_tester.o psb_d_mvsv_tester.o psb_c_mvsv_tester.o \ + psb_z_mvsv_tester.o +EXEDIR=./runs + + +all: runsd psbtf + +runsd: + (if test ! -d runs ; then mkdir runs; fi) + +psbtf.o: psb_mvsv_tester.o +psb_mvsv_tester.o: psb_s_mvsv_tester.o psb_d_mvsv_tester.o psb_c_mvsv_tester.o \ + psb_z_mvsv_tester.o + +psbtf: $(PSBTOBJS) + $(FLINK) $(PSBTOBJS) -o psbtf $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psbtf $(EXEDIR) + +psbtf.o: psb_mvsv_tester.o + + +.f90.o: + $(MPFC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $< + + +clean: + /bin/rm -f $(PSBTOBJS) ppde.o spde.o $(EXEDIR)/ppde +verycleanlib: + (cd ../..; make veryclean) +lib: + (cd ../../; make library) + + + diff --git a/test/torture/psb_c_mvsv_tester.f90 b/test/torture/psb_c_mvsv_tester.f90 new file mode 100644 index 00000000..ed6a9423 --- /dev/null +++ b/test/torture/psb_c_mvsv_tester.f90 @@ -0,0 +1,2811 @@ +module psb_c_mvsv_tester +contains + + subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 1+1i 2+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,1.e0), (2,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,3.e0), (12,9)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_ap3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 0+1i 2+6i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (0.e0,1.e0), (2,6)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,6.e0), (9,18)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_ap3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 3+2i + ! 0+3i 2+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,2.e0), (0.e0,3.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,-12.e0), (18,-6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_ap3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 3+3i 6+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (3.e0,3.e0), (6,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(3.e0,3.e0), (27,9)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 1+2i 2+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,2.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,9.e0), (6,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+0i 2+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(3.e0,-3.e0), (9,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 5+1i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (5,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,1.e0), (8,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_ap1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 1+0i + ! 0+1i 0+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,2.e0), (4,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_ap1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 0+2i + ! 0+3i 2+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (0.e0,2.e0), (0.e0,3.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,-4.e0), (5,-2)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_ap1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+0i 3+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (3,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(2.e0,1.e0), (3,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 0+1i + ! 0+1i 3+5i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (0.e0,1.e0), (3,5)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,2.e0), (3,6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 0+1i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,-1.e0), (0,-1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 0+0i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(2.e0,-1.e0), (2,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_am1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 3+0i + ! 1+3i 0+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,0.e0), (1.e0,3.e0), (0,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,-4.e0), (0,-2)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_am1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 1+2i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,3.e0), (3,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_am1_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 2+0i 1+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (2.e0,0.e0), (1,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-2.e0,-1.e0), (-3,-1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+3i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-1.e0,-1.e0), (-1,-3)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+1i 5+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,1.e0), (5,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-1.e0,2.e0), (-6,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 3+1i 2+4i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (3.e0,1.e0), (2,4)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(0.e0,-3.e0), (-12,-15)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_am3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 0+1i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(0.e0,-3.e0), (3,-3)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_am3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 1+0i + ! 1+1i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (1,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,6.e0), (0,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_am3_bp1_ix1_iy1 + ! + + subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 0+2i 0+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (0.e0,2.e0), (0,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,-3.e0), (0,-12)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_usmv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 3+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,3.e0), (3,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-6.e0,-12.e0), (-9,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_usmv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 3+1i + ! 0+1i 3+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,1.e0), (0.e0,1.e0), (3,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,6.e0), (-18,6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_usmv_2_c_am3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/1, 1, 1/) + complex*8 :: x(2)=(/3, 6/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_ussv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+2i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,2.e0), (1,0)/) + complex*8 :: x(2)=(/(3.e0,6.e0), (3,0)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_ussv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,4.e0), (1,0)/) + complex*8 :: x(2)=(/(3.e0,-12.e0), (3,0)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_ussv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+1i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/(1.e0,0.e0), (1,1)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_ussv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_ussv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 3+3i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (3.e0,3.e0), (1,0)/) + complex*8 :: x(2)=(/(4.e0,-3.e0), (1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_ussv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1 0 + ! 5 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/1, 5, 1/) + complex*8 :: x(2)=(/-1, -6/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_ussv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 1+2i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (1.e0,2.e0), (1,0)/) + complex*8 :: x(2)=(/(-2.e0,-2.e0), (-1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_ussv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,4.e0), (1,0)/) + complex*8 :: x(2)=(/(-1.e0,4.e0), (-1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_ussv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 1+1i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (1.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/(-3.e0,0.e0), (-6,-3)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine c_ussv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/-3, -3/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine c_ussv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/-3, -3/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine c_ussv_2_c_am3_bm0_ix1_iy1 + ! +end module psb_c_mvsv_tester diff --git a/test/torture/psb_d_mvsv_tester.f90 b/test/torture/psb_d_mvsv_tester.f90 new file mode 100644 index 00000000..baabf216 --- /dev/null +++ b/test/torture/psb_d_mvsv_tester.f90 @@ -0,0 +1,2812 @@ +module psb_d_mvsv_tester +contains + + + subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 1 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/9, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_ap3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/6, 6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_ap3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/15, 6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_ap3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/12, 9/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/12, 9/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 0 2 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 2/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/4, 5/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_ap1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/5, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_ap1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/4, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_ap1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 3 4 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 4/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 7/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 0 3 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 2/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_am1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 3 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_am1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 0 + ! 0 3 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_am1_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 3 + ! 0 3 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-4, -3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 3 5 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 5/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-4, -5/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 2 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 2/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-1, -2/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 0 + ! 0 6 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 6/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/0, -15/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_am3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 2 + ! 1 3 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + real*8 :: VA(4)=(/1, 2, 1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, -12/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_am3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-9, -6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_am3_bp1_ix1_iy1 + ! + + subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_usmv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_usmv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_usmv_2_c_am3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/3, 12/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_ussv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 2, 1/) + real*8 :: x(2)=(/9, 3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_ussv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/12, 3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_ussv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 4/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_ussv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/2, 1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_ussv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_ussv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/-1, -2/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_ussv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 6 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 6, 1/) + real*8 :: x(2)=(/-7, -1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_ussv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 2, 1/) + real*8 :: x(2)=(/-3, -1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_ussv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/-3, -6/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine d_ussv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/-3, -3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine d_ussv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/-3, -3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine d_ussv_2_c_am3_bm0_ix1_iy1 + ! +end module psb_d_mvsv_tester diff --git a/test/torture/psb_mvsv_tester.f90 b/test/torture/psb_mvsv_tester.f90 new file mode 100644 index 00000000..f997bf01 --- /dev/null +++ b/test/torture/psb_mvsv_tester.f90 @@ -0,0 +1,6 @@ +module psb_mvsv_tester + use psb_s_mvsv_tester + use psb_d_mvsv_tester + use psb_c_mvsv_tester + use psb_z_mvsv_tester +end module psb_mvsv_tester diff --git a/test/torture/psb_s_mvsv_tester.f90 b/test/torture/psb_s_mvsv_tester.f90 new file mode 100644 index 00000000..34c1e9eb --- /dev/null +++ b/test/torture/psb_s_mvsv_tester.f90 @@ -0,0 +1,2809 @@ +module psb_s_mvsv_tester +contains + subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_ap3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_ap3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 2 + ! 0 6 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 2, 6/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/6, 27/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_ap3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 2 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 3 + ! 2 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 3, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/6, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*4 :: VA(1)=(/1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/4, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_ap1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/5, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_ap1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 2 + ! 5 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 2, 5, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_ap1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 1 + ! 2 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 3 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 3, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 4/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 2, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/3, 1/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 3 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 3/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_am1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 1 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 1/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_am1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 0 + ! 1 2 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_am1_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, -2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 4 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 4, 3, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-4, -5/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, -2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 3 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 3, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-9, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_am3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 4 + ! 1 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 4, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -9/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_am3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/0, -3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_am3_bp1_ix1_iy1 + ! + + subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 2 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_usmv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + real*4 :: VA(1)=(/1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_usmv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_usmv_2_c_am3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/3, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_ussv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/3, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_ussv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/6, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,i,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_ussv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_ussv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_ussv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_ussv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-1, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_ussv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 3, 1/) + real*4 :: x(2)=(/-4, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_ussv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 2, 1/) + real*4 :: x(2)=(/-3, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_ussv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine s_ussv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine s_ussv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine s_ussv_2_c_am3_bm0_ix1_iy1 + ! +end module psb_s_mvsv_tester diff --git a/test/torture/psb_z_mvsv_tester.f90 b/test/torture/psb_z_mvsv_tester.f90 new file mode 100644 index 00000000..bc84a447 --- /dev/null +++ b/test/torture/psb_z_mvsv_tester.f90 @@ -0,0 +1,2810 @@ +module psb_z_mvsv_tester +contains + + subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 1+0i + ! 5+1i 1+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (5.e0,1.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(9.e0,3.e0), (21,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_ap3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+3i 2+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,3.e0), (2,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(12.e0,12.e0), (9,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_ap3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+0i 1+3i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,0.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(12.e0,-3.e0), (6,-9)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_ap3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+0i 0+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (0,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(3.e0,3.e0), (0,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+1i + ! 1+0i 3+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (1.e0,0.e0), (3,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(6.e0,3.e0), (9,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(6.e0,-12.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+3i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (0,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,1.e0), (3,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_ap1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+1i 1+3i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,2.e0), (4,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_ap1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 1+3i + ! 0+0i 0+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (1.e0,3.e0), (0,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,-1.e0), (4,-5)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_ap1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 3+2i + ! 0+0i 0+4i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (3.e0,2.e0), (0,4)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,3.e0), (0,4)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,4.e0), (1,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(1.e0,5.e0), (1,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-4.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 3+2i 1+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (3.e0,2.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-1.e0), (-1,-3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_am1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+3i 0+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,3.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-4.e0), (3,-1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_am1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,4.e0), (1,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,5.e0), (2,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_am1_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 5+3i 2+2i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (5.e0,3.e0), (2,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-1.e0,-1.e0), (-7,-5)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 1+0i + ! 0+3i 3+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,3.e0), (3,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-1.e0,-4.e0), (-4,-1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 2+0i + ! 1+0i 0+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (2.e0,0.e0), (1.e0,0.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-2.e0,1.e0), (-2,1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+3i 0+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,3.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(0.e0,-3.e0), (-3,-12)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_am3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 1+4i 2+4i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (1.e0,4.e0), (2,4)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-15.e0), (-3,-12)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_am3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+2i + ! 2+0i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 1, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 2, 1/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,2.e0), (2,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-6.e0,3.e0), (3,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_am3_bp1_ix1_iy1 + ! + + subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+3i + ! 0+1i 1+1i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,3.e0), (0.e0,1.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-12.e0), (-3,-6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_usmv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+1i + ! 0+3i 1+5i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=4 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(4)=(/1, 1, 2, 2/) + integer(psb_ipk_) :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (0.e0,3.e0), (1,5)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-12.e0), (-3,-18)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_usmv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + integer(psb_ipk_) :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=1 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(1)=(/1/) + integer(psb_ipk_) :: JA(1)=(/1/) + complex*16 :: VA(1)=(/(1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,3.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_usmv_2_c_am3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 0+2i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (0.e0,2.e0), (1,0)/) + complex*16 :: x(2)=(/(3.e0,0.e0), (3,6)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_ussv_2_n_ap3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 0+1i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (0.e0,1.e0), (1,0)/) + complex*16 :: x(2)=(/(3.e0,3.e0), (3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_ussv_2_t_ap3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 1, 1/) + complex*16 :: x(2)=(/6, 3/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_ussv_2_c_ap3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 1+5i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (1.e0,5.e0), (1,0)/) + complex*16 :: x(2)=(/(1.e0,0.e0), (2,5)/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_ussv_2_n_ap1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/1, 1/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_ussv_2_t_ap1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/3, 1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_ussv_2_c_ap1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/-1, -3/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_ussv_2_n_am1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=2 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(2)=(/1, 2/) + integer(psb_ipk_) :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/1, 1/) + complex*16 :: x(2)=(/-1, -1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_ussv_2_t_am1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/-3, -1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_ussv_2_c_am1_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='n' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 1, 1/) + complex*16 :: x(2)=(/-3, -6/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + end subroutine z_ussv_2_n_am3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='t' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 1+3i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (1.e0,3.e0), (1,0)/) + complex*16 :: x(2)=(/(-6.e0,-9.e0), (-3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + end subroutine z_ussv_2_t_am3_bm0_ix1_iy1 + ! + + subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + use psb_base_mod + implicit none + character(len=*) :: afmt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 + integer(psb_ipk_) :: info=-1 + + integer(psb_ipk_) ::res,istat=0,i + character::transa='c' + integer(psb_ipk_) :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 2+3i 1+0i + + ! declaration of VA,IA,JA + integer(psb_ipk_) :: nnz=3 + integer(psb_ipk_) :: m=2 + integer(psb_ipk_) :: k=2 + integer(psb_ipk_) :: IA(3)=(/1, 2, 2/) + integer(psb_ipk_) :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (2.e0,3.e0), (1,0)/) + complex*16 :: x(2)=(/(-9.e0,9.e0), (-3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ctxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) + if (info /= psb_success_)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= psb_success_)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ctxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= psb_success_)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 + enddo +9996 continue + if(info /= psb_success_)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= psb_success_)goto 9997 +9997 continue + if(info /= psb_success_)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= psb_success_)goto 9998 +9998 continue + if(info /= psb_success_)res=res+1 +9999 continue + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + end subroutine z_ussv_2_c_am3_bm0_ix1_iy1 +end module psb_z_mvsv_tester diff --git a/test/torture/psbtf.f90 b/test/torture/psbtf.f90 new file mode 100644 index 00000000..35851ada --- /dev/null +++ b/test/torture/psbtf.f90 @@ -0,0 +1,754 @@ +! +! Parallel Sparse BLAS fortran interface testing code +! +! +! + +program main + + use psb_base_mod + use psb_mvsv_tester + implicit none + integer(psb_ipk_), parameter :: psb_fidasize_=16 + integer(psb_ipk_) :: res,passed=0,failed=0; + integer(psb_ipk_) :: ctxt, iam=-1, np=-1 + character(len=psb_fidasize_) :: afmt + + write(psb_out_unit,*) 'Format ?' + read(psb_inp_unit,*) afmt +! afmt = 'COO' + + call psb_init(ctxt) + call psb_info(ctxt,iam,np) + if(iam<0)then + goto 9999 + endif + call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) + if(res /= 0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + +9999 continue + print *,"PASSED:",passed + print *,"FAILED:",failed + call psb_exit(ctxt) + +end program main + + + From ce1da012c95227ce70e833b9d8c49befbd805868 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 4 Jun 2021 15:03:36 +0200 Subject: [PATCH 03/15] added vect_set_vect --- cbind/base/psb_c_cbase.h | 2 ++ cbind/base/psb_c_dbase.h | 2 ++ cbind/base/psb_c_sbase.h | 2 ++ cbind/base/psb_c_serial_cbind_mod.F90 | 47 +++++++++++++++++++++++++++ cbind/base/psb_c_zbase.h | 2 ++ cbind/base/psb_d_serial_cbind_mod.F90 | 47 +++++++++++++++++++++++++++ cbind/base/psb_s_serial_cbind_mod.F90 | 47 +++++++++++++++++++++++++++ cbind/base/psb_z_serial_cbind_mod.F90 | 47 +++++++++++++++++++++++++++ 8 files changed, 196 insertions(+) diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 55c437a4..dd64d6e2 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -54,6 +54,8 @@ psb_i_t psb_c_ccopy_mat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_c_descriptor *cd /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); +psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); +psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); /* psblas computational routines */ psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 40d59a58..8c2c6a61 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -54,6 +54,8 @@ psb_i_t psb_c_dcopy_mat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_c_descriptor *cd /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); +psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val); +psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n); /* psblas computational routines */ psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index 73e3aa2d..b2e18ba5 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -54,6 +54,8 @@ psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cd /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); +psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val); +psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n); /* psblas computational routines */ psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index d46e776c..357810df 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -157,5 +157,52 @@ contains end function psb_c_cmat_name_print + function psb_c_cvect_set_scal(x,val) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + complex(c_float_complex), value :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val) + + info = 0 + + end function psb_c_cvect_set_scal + + function psb_c_cvect_set_vect(x,val,n) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + complex(c_float_complex) :: val(*) + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val(1:n)) + + info = 0 + + end function psb_c_cvect_set_vect + end module psb_c_serial_cbind_mod diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index ee74a651..16ee1ac4 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -55,6 +55,8 @@ psb_i_t psb_c_zcopy_mat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_c_descriptor *cd /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); +psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val); +psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n); /* psblas computational routines */ psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index f8f742fc..8e76ca3d 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -157,5 +157,52 @@ contains end function psb_c_dmat_name_print + function psb_c_dvect_set_scal(x,val) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + real(c_double), value :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val) + + info = 0 + + end function psb_c_dvect_set_scal + + function psb_c_dvect_set_vect(x,val,n) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + real(c_double) :: val(*) + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val(1:n)) + + info = 0 + + end function psb_c_dvect_set_vect + end module psb_d_serial_cbind_mod diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index 65a0bae7..107671c5 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -157,5 +157,52 @@ contains end function psb_c_smat_name_print + function psb_c_svect_set_scal(x,val) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + real(c_float), value :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val) + + info = 0 + + end function psb_c_svect_set_scal + + function psb_c_svect_set_vect(x,val,n) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + real(c_float) :: val(*) + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val(1:n)) + + info = 0 + + end function psb_c_svect_set_vect + end module psb_s_serial_cbind_mod diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index 01dfa018..0a4b3a0f 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -157,5 +157,52 @@ contains end function psb_c_zmat_name_print + function psb_c_zvect_set_scal(x,val) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + complex(c_double_complex), value :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val) + + info = 0 + + end function psb_c_zvect_set_scal + + function psb_c_zvect_set_vect(x,val,n) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + complex(c_double_complex) :: val(*) + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val(1:n)) + + info = 0 + + end function psb_c_zvect_set_vect + end module psb_z_serial_cbind_mod From bee4bebd7afde55d5adf18244db276c72d0848de Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 4 Jun 2021 16:49:05 +0200 Subject: [PATCH 04/15] Fixed missing bind(c) --- cbind/base/psb_c_serial_cbind_mod.F90 | 4 ++-- cbind/base/psb_d_serial_cbind_mod.F90 | 4 ++-- cbind/base/psb_s_serial_cbind_mod.F90 | 4 ++-- cbind/base/psb_z_serial_cbind_mod.F90 | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index 357810df..b298d84a 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -157,7 +157,7 @@ contains end function psb_c_cmat_name_print - function psb_c_cvect_set_scal(x,val) result(info) + function psb_c_cvect_set_scal(x,val) bind(c) result(info) use psb_base_mod implicit none @@ -180,7 +180,7 @@ contains end function psb_c_cvect_set_scal - function psb_c_cvect_set_vect(x,val,n) result(info) + function psb_c_cvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 8e76ca3d..984f826f 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -157,7 +157,7 @@ contains end function psb_c_dmat_name_print - function psb_c_dvect_set_scal(x,val) result(info) + function psb_c_dvect_set_scal(x,val) bind(c) result(info) use psb_base_mod implicit none @@ -180,7 +180,7 @@ contains end function psb_c_dvect_set_scal - function psb_c_dvect_set_vect(x,val,n) result(info) + function psb_c_dvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index 107671c5..83dac1a5 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -157,7 +157,7 @@ contains end function psb_c_smat_name_print - function psb_c_svect_set_scal(x,val) result(info) + function psb_c_svect_set_scal(x,val) bind(c) result(info) use psb_base_mod implicit none @@ -180,7 +180,7 @@ contains end function psb_c_svect_set_scal - function psb_c_svect_set_vect(x,val,n) result(info) + function psb_c_svect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index 0a4b3a0f..b61060b9 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -157,7 +157,7 @@ contains end function psb_c_zmat_name_print - function psb_c_zvect_set_scal(x,val) result(info) + function psb_c_zvect_set_scal(x,val) bind(c) result(info) use psb_base_mod implicit none @@ -180,7 +180,7 @@ contains end function psb_c_zvect_set_scal - function psb_c_zvect_set_vect(x,val,n) result(info) + function psb_c_zvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none From 6f92b7bfb3d8c7af1456a2ea93ce538b0c5e7a9b Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 7 Jun 2021 12:18:32 -0400 Subject: [PATCH 05/15] Simplify G2L --- base/modules/desc/psb_gen_block_map_mod.F90 | 883 -------------------- base/modules/desc/psb_hash_map_mod.f90 | 151 +++- base/modules/desc/psb_list_map_mod.f90 | 660 ++++----------- 3 files changed, 295 insertions(+), 1399 deletions(-) diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index b4f798d9..8daa038f 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -82,31 +82,16 @@ module psb_gen_block_map_mod procedure, pass(idxmap) :: reinit => block_reinit procedure, nopass :: get_fmt => block_get_fmt -!!$ procedure, pass(idxmap) :: l2gs1 => block_l2gs1 -!!$ procedure, pass(idxmap) :: l2gs2 => block_l2gs2 -!!$ procedure, pass(idxmap) :: l2gv1 => block_l2gv1 -!!$ procedure, pass(idxmap) :: l2gv2 => block_l2gv2 - procedure, pass(idxmap) :: ll2gs1 => block_ll2gs1 procedure, pass(idxmap) :: ll2gs2 => block_ll2gs2 procedure, pass(idxmap) :: ll2gv1 => block_ll2gv1 procedure, pass(idxmap) :: ll2gv2 => block_ll2gv2 -!!$ procedure, pass(idxmap) :: g2ls1 => block_g2ls1 -!!$ procedure, pass(idxmap) :: g2ls2 => block_g2ls2 -!!$ procedure, pass(idxmap) :: g2lv1 => block_g2lv1 -!!$ procedure, pass(idxmap) :: g2lv2 => block_g2lv2 - procedure, pass(idxmap) :: lg2ls1 => block_lg2ls1 procedure, pass(idxmap) :: lg2ls2 => block_lg2ls2 procedure, pass(idxmap) :: lg2lv1 => block_lg2lv1 procedure, pass(idxmap) :: lg2lv2 => block_lg2lv2 -!!$ procedure, pass(idxmap) :: g2ls1_ins => block_g2ls1_ins -!!$ procedure, pass(idxmap) :: g2ls2_ins => block_g2ls2_ins -!!$ procedure, pass(idxmap) :: g2lv1_ins => block_g2lv1_ins -!!$ procedure, pass(idxmap) :: g2lv2_ins => block_g2lv2_ins - procedure, pass(idxmap) :: lg2ls1_ins => block_lg2ls1_ins procedure, pass(idxmap) :: lg2ls2_ins => block_lg2ls2_ins procedure, pass(idxmap) :: lg2lv1_ins => block_lg2lv1_ins @@ -173,165 +158,6 @@ contains end subroutine block_free -!!$ -!!$ subroutine block_l2gs1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: idxv(1) -!!$ info = 0 -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ -!!$ idxv(1) = idx -!!$ call idxmap%l2gip(idxv,info,owned=owned) -!!$ idx = idxv(1) -!!$ -!!$ end subroutine block_l2gs1 -!!$ -!!$ subroutine block_l2gs2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ -!!$ idxout = idxin -!!$ call idxmap%l2gip(idxout,info,mask,owned) -!!$ -!!$ end subroutine block_l2gs2 -!!$ -!!$ -!!$ subroutine block_l2gv1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: i -!!$ logical :: owned_ -!!$ info = 0 -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ if (present(mask)) then -!!$ -!!$ do i=1, size(idx) -!!$ if (mask(i)) then -!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then -!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1 -!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, size(idx) -!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then -!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1 -!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ -!!$ end subroutine block_l2gv1 -!!$ -!!$ subroutine block_l2gv2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: is, im, i -!!$ logical :: owned_ -!!$ -!!$ info = 0 -!!$ -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < im) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ if (present(mask)) then -!!$ -!!$ do i=1, im -!!$ if (mask(i)) then -!!$ if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then -!!$ idxout(i) = idxmap%min_glob_row + idxin(i) - 1 -!!$ else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows) -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, im -!!$ if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then -!!$ idxout(i) = idxmap%min_glob_row + idxin(i) - 1 -!!$ else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows) -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ -!!$ if (is > im) then -!!$ info = -3 -!!$ end if -!!$ -!!$ end subroutine block_l2gv2 -!!$ - subroutine block_ll2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap @@ -365,7 +191,6 @@ contains end subroutine block_ll2gs2 - subroutine block_ll2gv1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap @@ -489,269 +314,6 @@ contains end subroutine block_ll2gv2 -!!$ subroutine block_g2ls1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: idxv(1) -!!$ info = 0 -!!$ -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ -!!$ idxv(1) = idx -!!$ call idxmap%g2lip(idxv,info,owned=owned) -!!$ idx = idxv(1) -!!$ -!!$ end subroutine block_g2ls1 -!!$ -!!$ subroutine block_g2ls2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ -!!$ idxout = idxin -!!$ call idxmap%g2lip(idxout,info,mask,owned) -!!$ -!!$ end subroutine block_g2ls2 -!!$ -!!$ -!!$ subroutine block_g2lv1(idx,idxmap,info,mask,owned) -!!$ use psb_penv_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: i, nv, is, ip, lip -!!$ integer(psb_lpk_) :: tidx -!!$ integer(psb_mpk_) :: ctxt, iam, np -!!$ logical :: owned_ -!!$ -!!$ info = 0 -!!$ ctxt = idxmap%get_ctxt() -!!$ call psb_info(ctxt,iam,np) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$! !$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ is = size(idx) -!!$ if (present(mask)) then -!!$ -!!$ if (idxmap%is_asb()) then -!!$ do i=1, is -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ nv = size(idxmap%srt_g2l,1) -!!$ tidx = idx(i) -!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1)) -!!$ if (idx(i) > 0) idx(i) = idxmap%srt_g2l(idx(i),2)+idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ else if (idxmap%is_valid()) then -!!$ do i=1,is -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ ip = idx(i) -!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) -!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ else -!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() -!!$ idx(1:is) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ if (idxmap%is_asb()) then -!!$ do i=1, is -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ nv = size(idxmap%srt_g2l,1) -!!$ tidx = idx(i) -!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1)) -!!$ if (idx(i) > 0) idx(i) = idxmap%srt_g2l(idx(i),2)+idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ -!!$ else if (idxmap%is_valid()) then -!!$ do i=1,is -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ ip = idx(i) -!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) -!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ else -!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() -!!$ idx(1:is) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ end if -!!$ -!!$ end subroutine block_g2lv1 -!!$ -!!$ subroutine block_g2lv2(idxin,idxout,idxmap,info,mask,owned) -!!$ use psb_penv_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_gen_block_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ -!!$ integer(psb_ipk_) :: i, nv, is, ip, lip, im -!!$ integer(psb_lpk_) :: tidx -!!$ integer(psb_mpk_) :: ctxt, iam, np -!!$ logical :: owned_ -!!$ -!!$ info = 0 -!!$ ctxt = idxmap%get_ctxt() -!!$ call psb_info(ctxt,iam,np) -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < im) then -!!$! !$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ if (present(mask)) then -!!$ -!!$ if (idxmap%is_asb()) then -!!$ do i=1, im -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ nv = size(idxmap%srt_g2l,1) -!!$ tidx = idxin(i) -!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1)) -!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_g2l(idxout(i),2)+idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ else if (idxmap%is_valid()) then -!!$ do i=1,im -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ ip = idxin(i) -!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) -!!$ if (lip > 0) idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ else -!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() -!!$ idxout(1:im) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ if (idxmap%is_asb()) then -!!$ do i=1, im -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ nv = size(idxmap%srt_g2l,1) -!!$ tidx = idxin(i) -!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1)) -!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_g2l(idxout(i),2)+idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ end if -!!$ end do -!!$ -!!$ else if (idxmap%is_valid()) then -!!$ do i=1,im -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& -!!$ &.and.(.not.owned_)) then -!!$ ip = idxin(i) -!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) -!!$ if (lip > 0) idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ end if -!!$ end do -!!$ else -!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() -!!$ idxout(1:im) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ end if -!!$ -!!$ if (is > im) info = -3 -!!$ -!!$ end subroutine block_g2lv2 - - subroutine block_lg2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap @@ -794,7 +356,6 @@ contains end subroutine block_lg2ls2 - subroutine block_lg2lv1(idx,idxmap,info,mask,owned) use psb_penv_mod use psb_sort_mod @@ -1033,449 +594,6 @@ contains end subroutine block_lg2lv2 -!!$ subroutine block_g2ls1_ins(idx,idxmap,info,mask, lidx) -!!$ use psb_realloc_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_gen_block_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ integer(psb_ipk_), intent(in), optional :: lidx -!!$ -!!$ integer(psb_ipk_) :: idxv(1), lidxv(1) -!!$ -!!$ info = 0 -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ idxv(1) = idx -!!$ if (present(lidx)) then -!!$ lidxv(1) = lidx -!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv) -!!$ else -!!$ call idxmap%g2lip_ins(idxv,info) -!!$ end if -!!$ idx = idxv(1) -!!$ -!!$ end subroutine block_g2ls1_ins -!!$ -!!$ subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) -!!$ implicit none -!!$ class(psb_gen_block_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ integer(psb_ipk_), intent(in), optional :: lidx -!!$ -!!$ idxout = idxin -!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) -!!$ -!!$ end subroutine block_g2ls2_ins -!!$ -!!$ -!!$ subroutine block_g2lv1_ins(idx,idxmap,info,mask,lidx) -!!$ use psb_realloc_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_gen_block_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) -!!$ -!!$ integer(psb_ipk_) :: i, nv, is, ix -!!$ integer(psb_ipk_) :: ip, lip, nxt -!!$ -!!$ -!!$ info = 0 -!!$ is = size(idx) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(lidx)) then -!!$ if (size(lidx) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ -!!$ -!!$ if (idxmap%is_asb()) then -!!$ ! State is wrong for this one ! -!!$ idx = -1 -!!$ info = -1 -!!$ -!!$ else if (idxmap%is_valid()) then -!!$ -!!$ if (present(lidx)) then -!!$ if (present(mask)) then -!!$ -!!$ do i=1, is -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ -!!$ if (lidx(i) <= idxmap%local_rows) then -!!$ info = -5 -!!$ return -!!$ end if -!!$ nxt = lidx(i)-idxmap%local_rows -!!$ ip = idx(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) -!!$ idxmap%loc_to_glob(nxt) = idx(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, is -!!$ -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ if (lidx(i) <= idxmap%local_rows) then -!!$ info = -5 -!!$ return -!!$ end if -!!$ nxt = lidx(i)-idxmap%local_rows -!!$ ip = idx(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) -!!$ idxmap%loc_to_glob(nxt) = idx(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ -!!$ else if (.not.present(lidx)) then -!!$ -!!$ if (present(mask)) then -!!$ do i=1, is -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ nv = idxmap%local_cols-idxmap%local_rows -!!$ nxt = nv + 1 -!!$ ip = idx(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = nxt + idxmap%local_rows -!!$ idxmap%loc_to_glob(nxt) = idx(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, is -!!$ -!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then -!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ nv = idxmap%local_cols-idxmap%local_rows -!!$ nxt = nv + 1 -!!$ ip = idx(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = nxt + idxmap%local_rows -!!$ idxmap%loc_to_glob(nxt) = idx(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idx(i) = lip + idxmap%local_rows -!!$ else -!!$ idx(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ end if -!!$ -!!$ else -!!$ idx = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ end subroutine block_g2lv1_ins -!!$ -!!$ subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) -!!$ use psb_realloc_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_gen_block_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) -!!$ -!!$ integer(psb_ipk_) :: i, nv, is, ix, im -!!$ integer(psb_ipk_) :: ip, lip, nxt -!!$ -!!$ -!!$ info = 0 -!!$ -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < im) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(lidx)) then -!!$ if (size(lidx) < im) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ -!!$ if (idxmap%is_asb()) then -!!$ ! State is wrong for this one ! -!!$ idxout = -1 -!!$ info = -1 -!!$ -!!$ else if (idxmap%is_valid()) then -!!$ -!!$ if (present(lidx)) then -!!$ if (present(mask)) then -!!$ -!!$ do i=1, im -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then -!!$ -!!$ if (lidx(i) <= idxmap%local_rows) then -!!$ info = -5 -!!$ return -!!$ end if -!!$ nxt = lidx(i)-idxmap%local_rows -!!$ ip = idxin(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) -!!$ idxmap%loc_to_glob(nxt) = idxin(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, im -!!$ -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then -!!$ if (lidx(i) <= idxmap%local_rows) then -!!$ info = -5 -!!$ return -!!$ end if -!!$ nxt = lidx(i)-idxmap%local_rows -!!$ ip = idxin(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) -!!$ idxmap%loc_to_glob(nxt) = idxin(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ -!!$ else if (.not.present(lidx)) then -!!$ -!!$ if (present(mask)) then -!!$ do i=1, im -!!$ if (mask(i)) then -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then -!!$ nv = idxmap%local_cols-idxmap%local_rows -!!$ nxt = nv + 1 -!!$ ip = idxin(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = nxt + idxmap%local_rows -!!$ idxmap%loc_to_glob(nxt) = idxin(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, im -!!$ -!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then -!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 -!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then -!!$ nv = idxmap%local_cols-idxmap%local_rows -!!$ nxt = nv + 1 -!!$ ip = idxin(i) -!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) -!!$ -!!$ if (info >= 0) then -!!$ if (lip == nxt) then -!!$ ! We have added one item -!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = nxt + idxmap%local_rows -!!$ idxmap%loc_to_glob(nxt) = idxin(i) -!!$ end if -!!$ info = psb_success_ -!!$ else -!!$ info = -5 -!!$ return -!!$ end if -!!$ idxout(i) = lip + idxmap%local_rows -!!$ else -!!$ idxout(i) = -1 -!!$ info = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ end if -!!$ -!!$ else -!!$ idxout = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ if (is > im) then -!!$! !$ write(0,*) 'g2lv2_ins err -3' -!!$ info = -3 -!!$ end if -!!$ -!!$ end subroutine block_g2lv2_ins - subroutine block_lg2ls1_ins(idx,idxmap,info,mask, lidx) use psb_realloc_mod use psb_sort_mod @@ -1518,7 +636,6 @@ contains idxout = tidx end subroutine block_lg2ls2_ins - subroutine block_lg2lv1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index 6cb781eb..3cfd33a4 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -94,8 +94,6 @@ module psb_hash_map_mod procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins -!!$ procedure, pass(idxmap) :: hash_cpy -!!$ generic, public :: assignment(=) => hash_cpy procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map end type psb_hash_map @@ -443,6 +441,8 @@ contains end subroutine hash_g2lv1 subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) + use psb_penv_mod + use psb_sort_mod use psb_realloc_mod implicit none class(psb_hash_map), intent(in) :: idxmap @@ -452,17 +452,120 @@ contains logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: is, im - integer(psb_lpk_), allocatable :: tidx(:) + integer(psb_ipk_) :: i, lip, nrow, nrm, is, im + integer(psb_lpk_) :: ncol, ip, tlip, mglob + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np + logical :: owned_ is = size(idxin) im = min(is,size(idxout)) - call psb_realloc(im,tidx,info) - tidx(1:im) = idxin(1:im) - call idxmap%g2lip(tidx(1:im),info,mask,owned) - idxout(1:im) = tidx(1:im) - if (is > im) then - write(0,*) 'g2lv2 err -3' - info = -3 + + + info = 0 + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) + + if (present(mask)) then + if (size(mask) < size(idxin)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if + + is = min(size(idxin), size(idxout)) + + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + ncol = idxmap%get_lc() + if (owned_) then + nrm = nrow + else + nrm = ncol + end if + if (present(mask)) then + + if (idxmap%is_asb()) then + + call hash_inner_cnv(is,idxin,idxout,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,mask=mask, nrm=nrm) + + else if (idxmap%is_valid()) then + + do i = 1, is + if (mask(i)) then + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + idxout(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,nrm) + if (lip < 0) then + call psb_hash_searchkey(ip,tlip,idxmap%hash,info) + lip = tlip + end if + if (owned_) then + if (lip<=nrow) then + idxout(i) = lip + else + idxout(i) = -1 + endif + else + idxout(i) = lip + endif + end if + enddo + + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idxout(1:is) = -1 + info = -1 + end if + + else if (.not.present(mask)) then + + if (idxmap%is_asb()) then + + call hash_inner_cnv(is,idxin,idxout,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,nrm=nrm) + + else if (idxmap%is_valid()) then + + do i = 1, is + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + idxout(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,nrm) + if (lip < 0) then + call psb_hash_searchkey(ip,tlip,idxmap%hash,info) + lip = tlip + end if + if (owned_) then + if (lip<=nrow) then + idxout(i) = lip + else + idxout(i) = -1 + endif + else + idxout(i) = lip + endif + enddo + + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idxout(1:is) = -1 + info = -1 + + end if + end if end subroutine hash_g2lv2 @@ -1502,32 +1605,6 @@ contains return end subroutine hash_clone - -!!$ subroutine hash_cpy(outmap,idxmap) -!!$ use psb_penv_mod -!!$ use psb_error_mod -!!$ use psb_realloc_mod -!!$ implicit none -!!$ class(psb_hash_map), intent(in) :: idxmap -!!$ type(psb_hash_map), intent(out) :: outmap -!!$ integer(psb_ipk_) :: info -!!$ -!!$ info = psb_success_ -!!$ call idxmap%psb_indx_map%cpy(outmap%psb_indx_map,info) -!!$ if (info == psb_success_) then -!!$ outmap%hashvsize = idxmap%hashvsize -!!$ outmap%hashvmask = idxmap%hashvmask -!!$ end if -!!$ if (info == psb_success_)& -!!$ & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info) -!!$ if (info == psb_success_)& -!!$ & call psb_safe_ab_cpy(idxmap%hashv,outmap%hashv,info) -!!$ if (info == psb_success_)& -!!$ & call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info) -!!$ if (info == psb_success_)& -!!$ & call psb_hash_copy(idxmap%hash,outmap%hash,info) -!!$ end subroutine hash_cpy - subroutine hash_reinit(idxmap,info) use psb_penv_mod use psb_error_mod diff --git a/base/modules/desc/psb_list_map_mod.f90 b/base/modules/desc/psb_list_map_mod.f90 index 5c63aa6c..3e3c8e25 100644 --- a/base/modules/desc/psb_list_map_mod.f90 +++ b/base/modules/desc/psb_list_map_mod.f90 @@ -59,31 +59,16 @@ module psb_list_map_mod procedure, nopass :: get_fmt => list_get_fmt procedure, nopass :: row_extendable => list_row_extendable -!!$ procedure, pass(idxmap) :: l2gs1 => list_l2gs1 -!!$ procedure, pass(idxmap) :: l2gs2 => list_l2gs2 -!!$ procedure, pass(idxmap) :: l2gv1 => list_l2gv1 -!!$ procedure, pass(idxmap) :: l2gv2 => list_l2gv2 - procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1 procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2 procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1 procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2 -!!$ procedure, pass(idxmap) :: g2ls1 => list_g2ls1 -!!$ procedure, pass(idxmap) :: g2ls2 => list_g2ls2 -!!$ procedure, pass(idxmap) :: g2lv1 => list_g2lv1 -!!$ procedure, pass(idxmap) :: g2lv2 => list_g2lv2 - procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1 procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2 procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1 procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2 -!!$ procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins -!!$ procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins -!!$ procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins -!!$ procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins - procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins procedure, pass(idxmap) :: lg2lv1_ins => list_lg2lv1_ins @@ -135,115 +120,6 @@ contains end subroutine list_free - -!!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: idxv(1) -!!$ info = 0 -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ -!!$ idxv(1) = idx -!!$ call idxmap%l2gip(idxv,info,owned=owned) -!!$ idx = idxv(1) -!!$ -!!$ end subroutine list_l2gs1 -!!$ -!!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ -!!$ idxout = idxin -!!$ call idxmap%l2gip(idxout,info,mask,owned) -!!$ -!!$ end subroutine list_l2gs2 -!!$ -!!$ -!!$ subroutine list_l2gv1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: i -!!$ logical :: owned_ -!!$ info = 0 -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ if (present(mask)) then -!!$ -!!$ do i=1, size(idx) -!!$ if (mask(i)) then -!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)) -!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)) -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, size(idx) -!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)) -!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& -!!$ & .and.(.not.owned_)) then -!!$ idx(i) = idxmap%loc_to_glob(idx(i)) -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ -!!$ end subroutine list_l2gv1 -!!$ -!!$ subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: is, im -!!$ -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ idxout(1:im) = idxin(1:im) -!!$ call idxmap%l2gip(idxout(1:im),info,mask,owned) -!!$ if (is > im) info = -3 -!!$ -!!$ end subroutine list_l2gv2 -!!$ - subroutine list_ll2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap @@ -351,129 +227,6 @@ contains end subroutine list_ll2gv2 -!!$ -!!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: idxv(1) -!!$ info = 0 -!!$ -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ -!!$ idxv(1) = idx -!!$ call idxmap%g2lip(idxv,info,owned=owned) -!!$ idx = idxv(1) -!!$ -!!$ end subroutine list_g2ls1 -!!$ -!!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ logical, intent(in), optional :: owned -!!$ -!!$ idxout = idxin -!!$ call idxmap%g2lip(idxout,info,mask,owned) -!!$ -!!$ end subroutine list_g2ls2 -!!$ -!!$ -!!$ subroutine list_g2lv1(idx,idxmap,info,mask,owned) -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ integer(psb_ipk_) :: i, is, ix -!!$ logical :: owned_ -!!$ -!!$ info = 0 -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(owned)) then -!!$ owned_ = owned -!!$ else -!!$ owned_ = .false. -!!$ end if -!!$ -!!$ is = size(idx) -!!$ -!!$ if (present(mask)) then -!!$ if (idxmap%is_valid()) then -!!$ do i=1,is -!!$ if (mask(i)) then -!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ else -!!$ idx(1:is) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ if (idxmap%is_valid()) then -!!$ do i=1, is -!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ else -!!$ idx(1:is) = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ end if -!!$ -!!$ end subroutine list_g2lv1 -!!$ -!!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned) -!!$ implicit none -!!$ class(psb_list_map), intent(in) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ logical, intent(in), optional :: owned -!!$ -!!$ integer(psb_ipk_) :: is, im -!!$ -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ idxout(1:im) = idxin(1:im) -!!$ call idxmap%g2lip(idxout(1:im),info,mask,owned) -!!$ if (is > im) info = -3 -!!$ -!!$ end subroutine list_g2lv2 - - - subroutine list_lg2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap @@ -590,227 +343,66 @@ contains integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_lpk_), allocatable :: idxv(:) - integer(psb_ipk_) :: is, im - - is = size(idxin) - im = min(is,size(idxout)) - allocate(idxv(im),stat=info) - if (info /= 0) then - info = -5 - return + + integer(psb_ipk_) :: im + integer(psb_lpk_) :: i, is, ix + logical :: owned_ + + info = 0 + + if (present(mask)) then + if (size(mask) < size(idxin)) then + info = -1 + return + end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. end if - idxv(1:im) = idxin(1:im) - call idxmap%g2lip(idxv(1:im),info,mask,owned) - idxout(1:im) = idxv(1:im) - if (is > im) info = -3 - end subroutine list_lg2lv2 + is = min(size(idxin), size(idxout)) + if (present(mask)) then + if (idxmap%is_valid()) then + do i=1,is + if (mask(i)) then + if ((1 <= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 + idxout(i) = ix + else + idxout(i) = -1 + end if + end if + end do + else + idxout(1:is) = -1 + info = -1 + end if -!!$ subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx) -!!$ use psb_realloc_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_list_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ integer(psb_ipk_), intent(in), optional :: lidx -!!$ -!!$ integer(psb_ipk_) :: idxv(1), lidxv(1) -!!$ -!!$ info = 0 -!!$ if (present(mask)) then -!!$ if (.not.mask) return -!!$ end if -!!$ idxv(1) = idx -!!$ if (present(lidx)) then -!!$ lidxv(1) = lidx -!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv) -!!$ else -!!$ call idxmap%g2lip_ins(idxv,info) -!!$ end if -!!$ -!!$ idx = idxv(1) -!!$ -!!$ end subroutine list_g2ls1_ins -!!$ -!!$ subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) -!!$ implicit none -!!$ class(psb_list_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin -!!$ integer(psb_ipk_), intent(out) :: idxout -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask -!!$ integer(psb_ipk_), intent(in), optional :: lidx -!!$ -!!$ idxout = idxin -!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) -!!$ -!!$ end subroutine list_g2ls2_ins -!!$ -!!$ -!!$ subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx) -!!$ use psb_realloc_mod -!!$ use psb_sort_mod -!!$ implicit none -!!$ class(psb_list_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(inout) :: idx(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) -!!$ -!!$ integer(psb_ipk_) :: i, is, ix, lix -!!$ -!!$ info = 0 -!!$ is = size(idx) -!!$ -!!$ if (present(mask)) then -!!$ if (size(mask) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ if (present(lidx)) then -!!$ if (size(lidx) < size(idx)) then -!!$ info = -1 -!!$ return -!!$ end if -!!$ end if -!!$ -!!$ -!!$ if (idxmap%is_asb()) then -!!$ ! State is wrong for this one ! -!!$ idx = -1 -!!$ info = -1 -!!$ -!!$ else if (idxmap%is_valid()) then -!!$ -!!$ if (present(lidx)) then -!!$ if (present(mask)) then -!!$ do i=1, is -!!$ if (mask(i)) then -!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if (ix < 0) then -!!$ ix = lidx(i) -!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(ix,idxmap%local_cols) -!!$ idxmap%loc_to_glob(ix) = idx(i) -!!$ idxmap%glob_to_loc(idx(i)) = ix -!!$ end if -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, is -!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if (ix < 0) then -!!$ ix = lidx(i) -!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = max(ix,idxmap%local_cols) -!!$ idxmap%loc_to_glob(ix) = idx(i) -!!$ idxmap%glob_to_loc(idx(i)) = ix -!!$ end if -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ -!!$ else if (.not.present(lidx)) then -!!$ -!!$ if (present(mask)) then -!!$ do i=1, is -!!$ if (mask(i)) then -!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if (ix < 0) then -!!$ ix = idxmap%local_cols + 1 -!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = ix -!!$ idxmap%loc_to_glob(ix) = idx(i) -!!$ idxmap%glob_to_loc(idx(i)) = ix -!!$ end if -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ else if (.not.present(mask)) then -!!$ -!!$ do i=1, is -!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then -!!$ ix = idxmap%glob_to_loc(idx(i)) -!!$ if (ix < 0) then -!!$ ix = idxmap%local_cols + 1 -!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) -!!$ if (info /= 0) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ idxmap%local_cols = ix -!!$ idxmap%loc_to_glob(ix) = idx(i) -!!$ idxmap%glob_to_loc(idx(i)) = ix -!!$ end if -!!$ idx(i) = ix -!!$ else -!!$ idx(i) = -1 -!!$ end if -!!$ end do -!!$ end if -!!$ end if -!!$ -!!$ else -!!$ idx = -1 -!!$ info = -1 -!!$ end if -!!$ -!!$ end subroutine list_g2lv1_ins -!!$ -!!$ subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) -!!$ implicit none -!!$ class(psb_list_map), intent(inout) :: idxmap -!!$ integer(psb_ipk_), intent(in) :: idxin(:) -!!$ integer(psb_ipk_), intent(out) :: idxout(:) -!!$ integer(psb_ipk_), intent(out) :: info -!!$ logical, intent(in), optional :: mask(:) -!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) -!!$ -!!$ integer(psb_ipk_) :: is, im -!!$ -!!$ is = size(idxin) -!!$ im = min(is,size(idxout)) -!!$ idxout(1:im) = idxin(1:im) -!!$ call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx) -!!$ if (is > im) info = -3 -!!$ -!!$ end subroutine list_g2lv2_ins -!!$ + else if (.not.present(mask)) then + + if (idxmap%is_valid()) then + do i=1, is + if ((1 <= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 + idxout(i) = ix + else + idxout(i) = -1 + end if + end do + else + idxout(1:is) = -1 + info = -1 + end if + + end if + + end subroutine list_lg2lv2 - subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod @@ -1010,6 +602,7 @@ contains end subroutine list_lg2lv1_ins subroutine list_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + use psb_realloc_mod implicit none class(psb_list_map), intent(inout) :: idxmap integer(psb_lpk_), intent(in) :: idxin(:) @@ -1017,27 +610,136 @@ contains integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - - integer(psb_lpk_) :: is, im - integer(psb_lpk_), allocatable :: idxv(:) - - is = size(idxin) - im = min(is,size(idxout)) - allocate(idxv(im),stat=info) - if (info /= 0) then - info = -5 - return + + integer(psb_ipk_) :: ix, lix + integer(psb_lpk_) :: i, is + + info = 0 + is = min(size(idxin),size(idxout)) + + if (present(mask)) then + if (size(mask) < size(idxin)) then + info = -1 + return + end if + end if + if (present(lidx)) then + if (size(lidx) < size(idxin)) then + info = -1 + return + end if end if - - idxv(1:im) = idxin(1:im) - call idxmap%g2lip_ins(idxv(1:im),info,mask=mask,lidx=lidx) - idxout(1:im) = idxv(1:im) - if (is > im) info = -3 - end subroutine list_lg2lv2_ins + if (idxmap%is_asb()) then + ! State is wrong for this one ! + idxout = -1 + info = -1 + + else if (idxmap%is_valid()) then + + if (present(lidx)) then + if (present(mask)) then + do i=1, is + if (mask(i)) then + if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if ((ix <= idxmap%local_rows).or.(info /= 0)) then + info = -4 + return + end if + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + idxout(i) = ix + else + idxout(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, is + if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = lidx(i) + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if ((ix <= idxmap%local_rows).or.(info /= 0)) then + info = -4 + return + end if + idxmap%local_cols = max(ix,idxmap%local_cols) + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + idxout(i) = ix + else + idxout(i) = -1 + end if + end do + end if + + else if (.not.present(lidx)) then + + if (present(mask)) then + do i=1, is + if (mask(i)) then + if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + idxout(i) = ix + else + idxout(i) = -1 + end if + end if + end do + + else if (.not.present(mask)) then + + do i=1, is + if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then + ix = idxmap%glob_to_loc(idxin(i)) + if (ix < 0) then + ix = idxmap%local_cols + 1 + call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) + if (info /= 0) then + info = -4 + return + end if + idxmap%local_cols = ix + idxmap%loc_to_glob(ix) = idxin(i) + idxmap%glob_to_loc(idxin(i)) = ix + end if + idxout(i) = ix + else + idxout(i) = -1 + end if + end do + end if + end if + else + idxout = -1 + info = -1 + end if + end subroutine list_lg2lv2_ins subroutine list_initvl(idxmap,ctxt,vl,info) use psb_penv_mod From da7d49b4db09a146ce9d12afbd08b876ff9b085f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 17 Jun 2021 10:45:19 -0400 Subject: [PATCH 06/15] Cleanup use of %csget --- base/tools/psb_csphalo.F90 | 7 +------ base/tools/psb_dsphalo.F90 | 7 +------ base/tools/psb_ssphalo.F90 | 7 +------ base/tools/psb_zsphalo.F90 | 7 +------ 4 files changed, 4 insertions(+), 24 deletions(-) diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index 8731c093..19d7e1dc 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -295,7 +295,6 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -400,7 +399,6 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -748,7 +746,6 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -756,7 +753,7 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - tot_elem=tot_elem+n_elem + tot_elem=tot_elem+ngtz Enddo ipx = ipx + 1 counter = counter+n_el_send+3 @@ -1104,7 +1101,6 @@ Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then @@ -1469,7 +1465,6 @@ Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index e8a59e52..d5e383ef 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -295,7 +295,6 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -400,7 +399,6 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -748,7 +746,6 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -756,7 +753,7 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - tot_elem=tot_elem+n_elem + tot_elem=tot_elem+ngtz Enddo ipx = ipx + 1 counter = counter+n_el_send+3 @@ -1104,7 +1101,6 @@ Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then @@ -1469,7 +1465,6 @@ Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index 609d41b4..be0b340a 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -295,7 +295,6 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -400,7 +399,6 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -748,7 +746,6 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -756,7 +753,7 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - tot_elem=tot_elem+n_elem + tot_elem=tot_elem+ngtz Enddo ipx = ipx + 1 counter = counter+n_el_send+3 @@ -1104,7 +1101,6 @@ Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then @@ -1469,7 +1465,6 @@ Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index 6aece956..5e24a93c 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -295,7 +295,6 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -400,7 +399,6 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -748,7 +746,6 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) if (info /= psb_success_) then @@ -756,7 +753,7 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - tot_elem=tot_elem+n_elem + tot_elem=tot_elem+ngtz Enddo ipx = ipx + 1 counter = counter+n_el_send+3 @@ -1104,7 +1101,6 @@ Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then @@ -1469,7 +1465,6 @@ Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& Do j=0,n_el_send-1 idx = ipdxv(counter+psb_elem_send_+j) - n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem,jmax=ncg) if (info /= psb_success_) then From a673bf8bf16d7db7c0c4f89eaf975602bca5961b Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 17 Jun 2021 10:45:31 -0400 Subject: [PATCH 07/15] Fix inconsistency in %csget --- base/modules/serial/psb_c_mat_mod.F90 | 4 ++-- base/modules/serial/psb_d_mat_mod.F90 | 4 ++-- base/modules/serial/psb_s_mat_mod.F90 | 4 ++-- base/modules/serial/psb_z_mat_mod.F90 | 4 ++-- base/serial/impl/psb_c_mat_impl.F90 | 13 ++++++++----- base/serial/impl/psb_d_mat_impl.F90 | 13 ++++++++----- base/serial/impl/psb_s_mat_impl.F90 | 13 ++++++++----- base/serial/impl/psb_z_mat_impl.F90 | 13 ++++++++----- 8 files changed, 40 insertions(+), 28 deletions(-) diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index 5e889da2..f221a8f8 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -681,7 +681,7 @@ module psb_c_mat_mod interface subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax @@ -692,7 +692,7 @@ module psb_c_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_csgetrow end interface diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index caf03994..db997b8f 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -681,7 +681,7 @@ module psb_d_mat_mod interface subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax @@ -692,7 +692,7 @@ module psb_d_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_csgetrow end interface diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 8e3934b8..9f5f418b 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -681,7 +681,7 @@ module psb_s_mat_mod interface subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax @@ -692,7 +692,7 @@ module psb_s_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_csgetrow end interface diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index ed3338f9..a6632412 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -681,7 +681,7 @@ module psb_z_mat_mod interface subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax @@ -692,7 +692,7 @@ module psb_z_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_csgetrow end interface diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index cc112015..088b012d 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -820,7 +820,8 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -866,9 +867,10 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -929,8 +931,9 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) else info = psb_err_alloc_dealloc_ end if diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 7f4ac0c1..b21fa40f 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -820,7 +820,8 @@ subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -866,9 +867,10 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -929,8 +931,9 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) else info = psb_err_alloc_dealloc_ end if diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 806a08e3..c624dc2f 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -820,7 +820,8 @@ subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -866,9 +867,10 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -929,8 +931,9 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) else info = psb_err_alloc_dealloc_ end if diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index 422a664d..e008dfdb 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -820,7 +820,8 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -866,9 +867,10 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -929,8 +931,9 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) else info = psb_err_alloc_dealloc_ end if From 340c191e7f0e0273a83cbfc1ec86d49a0bb8299f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 18 Jun 2021 11:33:23 +0200 Subject: [PATCH 08/15] First round of cleanup build warnings --- base/comm/psb_dgather.f90 | 4 ++-- base/comm/psb_igather.f90 | 4 ++-- base/comm/psb_lgather.f90 | 4 ++-- base/comm/psb_sgather.f90 | 4 ++-- base/comm/psb_zgather.f90 | 4 ++-- base/modules/comm/psb_c_comm_mod.f90 | 2 +- base/modules/comm/psb_d_comm_mod.f90 | 2 +- base/modules/comm/psb_i_comm_mod.f90 | 2 +- base/modules/comm/psb_l_comm_mod.f90 | 2 +- base/modules/comm/psb_s_comm_mod.f90 | 2 +- base/modules/comm/psb_z_comm_mod.f90 | 2 +- base/modules/serial/psb_c_mat_mod.F90 | 8 ++++---- base/modules/serial/psb_d_mat_mod.F90 | 8 ++++---- base/modules/serial/psb_s_mat_mod.F90 | 8 ++++---- base/modules/serial/psb_z_mat_mod.F90 | 8 ++++---- base/serial/impl/psb_base_mat_impl.f90 | 6 +++--- base/serial/impl/psb_c_coo_impl.F90 | 7 ++++--- base/serial/impl/psb_c_csc_impl.f90 | 6 +++--- base/serial/impl/psb_c_csr_impl.f90 | 4 ++-- base/serial/impl/psb_d_coo_impl.F90 | 7 ++++--- base/serial/impl/psb_d_csc_impl.f90 | 6 +++--- base/serial/impl/psb_d_csr_impl.f90 | 4 ++-- base/serial/impl/psb_s_coo_impl.F90 | 7 ++++--- base/serial/impl/psb_s_csc_impl.f90 | 6 +++--- base/serial/impl/psb_s_csr_impl.f90 | 4 ++-- base/serial/impl/psb_z_coo_impl.F90 | 7 ++++--- base/serial/impl/psb_z_csc_impl.f90 | 6 +++--- base/serial/impl/psb_z_csr_impl.f90 | 4 ++-- 28 files changed, 71 insertions(+), 67 deletions(-) diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 8109d506..c1619b1b 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -64,7 +64,7 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) real(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_dgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -182,7 +182,7 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) real(psb_dpk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_dgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 2a01ee44..afa794eb 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -64,7 +64,7 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) integer(psb_ipk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_igatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -182,7 +182,7 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) integer(psb_ipk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_igatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 index eeb5a25d..00af3cd1 100644 --- a/base/comm/psb_lgather.f90 +++ b/base/comm/psb_lgather.f90 @@ -64,7 +64,7 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) integer(psb_lpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_lgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -182,7 +182,7 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot) integer(psb_lpk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_lgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 857f5fd6..21ce1408 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -64,7 +64,7 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) real(psb_spk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_sgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -182,7 +182,7 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) real(psb_spk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_sgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index b163094a..53cba210 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -64,7 +64,7 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) complex(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_zgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -182,7 +182,7 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) complex(psb_dpk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err - name='psb_cgatherv' + name='psb_zgatherv' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then diff --git a/base/modules/comm/psb_c_comm_mod.f90 b/base/modules/comm/psb_c_comm_mod.f90 index c2a85510..1bd46197 100644 --- a/base/modules/comm/psb_c_comm_mod.f90 +++ b/base/modules/comm/psb_c_comm_mod.f90 @@ -138,7 +138,7 @@ module psb_c_comm_mod import implicit none type(psb_c_multivect_type), intent(inout) :: locx - complex(psb_spk_), intent(out), allocatable :: globx(:) + complex(psb_spk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/comm/psb_d_comm_mod.f90 b/base/modules/comm/psb_d_comm_mod.f90 index 5efde2b0..013c76e2 100644 --- a/base/modules/comm/psb_d_comm_mod.f90 +++ b/base/modules/comm/psb_d_comm_mod.f90 @@ -138,7 +138,7 @@ module psb_d_comm_mod import implicit none type(psb_d_multivect_type), intent(inout) :: locx - real(psb_dpk_), intent(out), allocatable :: globx(:) + real(psb_dpk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/comm/psb_i_comm_mod.f90 b/base/modules/comm/psb_i_comm_mod.f90 index b727f403..25d761ba 100644 --- a/base/modules/comm/psb_i_comm_mod.f90 +++ b/base/modules/comm/psb_i_comm_mod.f90 @@ -107,7 +107,7 @@ module psb_i_comm_mod import implicit none type(psb_i_multivect_type), intent(inout) :: locx - integer(psb_ipk_), intent(out), allocatable :: globx(:) + integer(psb_ipk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/comm/psb_l_comm_mod.f90 b/base/modules/comm/psb_l_comm_mod.f90 index 1072b824..2bba923d 100644 --- a/base/modules/comm/psb_l_comm_mod.f90 +++ b/base/modules/comm/psb_l_comm_mod.f90 @@ -107,7 +107,7 @@ module psb_l_comm_mod import implicit none type(psb_l_multivect_type), intent(inout) :: locx - integer(psb_lpk_), intent(out), allocatable :: globx(:) + integer(psb_lpk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/comm/psb_s_comm_mod.f90 b/base/modules/comm/psb_s_comm_mod.f90 index a55e0c55..a202b5b6 100644 --- a/base/modules/comm/psb_s_comm_mod.f90 +++ b/base/modules/comm/psb_s_comm_mod.f90 @@ -138,7 +138,7 @@ module psb_s_comm_mod import implicit none type(psb_s_multivect_type), intent(inout) :: locx - real(psb_spk_), intent(out), allocatable :: globx(:) + real(psb_spk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/comm/psb_z_comm_mod.f90 b/base/modules/comm/psb_z_comm_mod.f90 index 58aabba2..304cdfb9 100644 --- a/base/modules/comm/psb_z_comm_mod.f90 +++ b/base/modules/comm/psb_z_comm_mod.f90 @@ -138,7 +138,7 @@ module psb_z_comm_mod import implicit none type(psb_z_multivect_type), intent(inout) :: locx - complex(psb_dpk_), intent(out), allocatable :: globx(:) + complex(psb_dpk_), intent(out), allocatable :: globx(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index f221a8f8..75699249 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -947,8 +947,8 @@ module psb_c_mat_mod interface subroutine psb_c_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat - class(psb_cspmat_type), intent(out) :: a - class(psb_lc_base_sparse_mat), intent(in) :: b + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_c_cp_from_lb end interface @@ -1731,8 +1731,8 @@ module psb_c_mat_mod interface subroutine psb_lc_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_lcspmat_type), intent(out) :: a - class(psb_c_base_sparse_mat), intent(in) :: b + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_cp_from_ib end interface diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index db997b8f..ff51d1cb 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -947,8 +947,8 @@ module psb_d_mat_mod interface subroutine psb_d_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_dspmat_type), intent(out) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_d_cp_from_lb end interface @@ -1731,8 +1731,8 @@ module psb_d_mat_mod interface subroutine psb_ld_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_ldspmat_type), intent(out) :: a - class(psb_d_base_sparse_mat), intent(in) :: b + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_cp_from_ib end interface diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 9f5f418b..849c64c3 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -947,8 +947,8 @@ module psb_s_mat_mod interface subroutine psb_s_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat - class(psb_sspmat_type), intent(out) :: a - class(psb_ls_base_sparse_mat), intent(in) :: b + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_s_cp_from_lb end interface @@ -1731,8 +1731,8 @@ module psb_s_mat_mod interface subroutine psb_ls_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_lsspmat_type), intent(out) :: a - class(psb_s_base_sparse_mat), intent(in) :: b + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_cp_from_ib end interface diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index a6632412..fc16ca80 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -947,8 +947,8 @@ module psb_z_mat_mod interface subroutine psb_z_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat - class(psb_zspmat_type), intent(out) :: a - class(psb_lz_base_sparse_mat), intent(in) :: b + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_z_cp_from_lb end interface @@ -1731,8 +1731,8 @@ module psb_z_mat_mod interface subroutine psb_lz_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_lzspmat_type), intent(out) :: a - class(psb_z_base_sparse_mat), intent(in) :: b + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_cp_from_ib end interface diff --git a/base/serial/impl/psb_base_mat_impl.f90 b/base/serial/impl/psb_base_mat_impl.f90 index faa91979..4ab03086 100644 --- a/base/serial/impl/psb_base_mat_impl.f90 +++ b/base/serial/impl/psb_base_mat_impl.f90 @@ -91,9 +91,9 @@ subroutine psb_base_sparse_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_), intent(in) :: iout class(psb_base_sparse_mat), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) + integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act, info character(len=20) :: name='sparse_print' @@ -384,7 +384,7 @@ subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) use psb_error_mod implicit none - integer(psb_lpk_), intent(in) :: iout + integer(psb_ipk_), intent(in) :: iout class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 4eb2f26e..442b2a48 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -592,7 +592,7 @@ subroutine psb_c_coo_clean_zeros(a, info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_zeros implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i,j,k, nzin @@ -5264,7 +5264,7 @@ subroutine psb_lc_coo_clean_zeros(a, info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_zeros implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i,j,k, nzin @@ -6760,7 +6760,8 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_sort_mod implicit none - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(in) :: nr, nc, nzin + integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) integer(psb_lpk_), intent(out) :: nzout diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index bfefebad..87d7e3dd 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2371,7 +2371,7 @@ subroutine psb_c_csc_clean_zeros(a, info) use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_clean_zeros implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nc integer(psb_ipk_), allocatable :: ilcp(:) @@ -4255,7 +4255,7 @@ subroutine psb_lc_csc_clean_zeros(a, info) use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_clean_zeros implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nc integer(psb_lpk_), allocatable :: ilcp(:) @@ -4319,7 +4319,7 @@ subroutine psb_lc_csc_reallocate_nz(nz,a) use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_reallocate_nz implicit none - integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: nz class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) character(len=20) :: name='lc_csc_reallocate_nz' diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index f4522a6f..c06d2755 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -3235,7 +3235,7 @@ subroutine psb_c_csr_clean_zeros(a, info) use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_clean_zeros implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nr integer(psb_ipk_), allocatable :: ilrp(:) @@ -5350,7 +5350,7 @@ subroutine psb_lc_csr_clean_zeros(a, info) use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_clean_zeros implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nr integer(psb_lpk_), allocatable :: ilrp(:) diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 6b3aafc8..88c1ef16 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -592,7 +592,7 @@ subroutine psb_d_coo_clean_zeros(a, info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_zeros implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i,j,k, nzin @@ -5264,7 +5264,7 @@ subroutine psb_ld_coo_clean_zeros(a, info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_zeros implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i,j,k, nzin @@ -6760,7 +6760,8 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_sort_mod implicit none - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(in) :: nr, nc, nzin + integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) integer(psb_lpk_), intent(out) :: nzout diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index eced8477..4f10439b 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2371,7 +2371,7 @@ subroutine psb_d_csc_clean_zeros(a, info) use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_clean_zeros implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nc integer(psb_ipk_), allocatable :: ilcp(:) @@ -4255,7 +4255,7 @@ subroutine psb_ld_csc_clean_zeros(a, info) use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_clean_zeros implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nc integer(psb_lpk_), allocatable :: ilcp(:) @@ -4319,7 +4319,7 @@ subroutine psb_ld_csc_reallocate_nz(nz,a) use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_reallocate_nz implicit none - integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: nz class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) character(len=20) :: name='ld_csc_reallocate_nz' diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index aa300c73..c251a2fd 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -3235,7 +3235,7 @@ subroutine psb_d_csr_clean_zeros(a, info) use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_clean_zeros implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nr integer(psb_ipk_), allocatable :: ilrp(:) @@ -5350,7 +5350,7 @@ subroutine psb_ld_csr_clean_zeros(a, info) use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_clean_zeros implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nr integer(psb_lpk_), allocatable :: ilrp(:) diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index d214b2d5..5a0a3279 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -592,7 +592,7 @@ subroutine psb_s_coo_clean_zeros(a, info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_zeros implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i,j,k, nzin @@ -5264,7 +5264,7 @@ subroutine psb_ls_coo_clean_zeros(a, info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_zeros implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i,j,k, nzin @@ -6760,7 +6760,8 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_sort_mod implicit none - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(in) :: nr, nc, nzin + integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) integer(psb_lpk_), intent(out) :: nzout diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index b16cb5bf..e52086d1 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2371,7 +2371,7 @@ subroutine psb_s_csc_clean_zeros(a, info) use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_clean_zeros implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nc integer(psb_ipk_), allocatable :: ilcp(:) @@ -4255,7 +4255,7 @@ subroutine psb_ls_csc_clean_zeros(a, info) use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_clean_zeros implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nc integer(psb_lpk_), allocatable :: ilcp(:) @@ -4319,7 +4319,7 @@ subroutine psb_ls_csc_reallocate_nz(nz,a) use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_reallocate_nz implicit none - integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: nz class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) character(len=20) :: name='ls_csc_reallocate_nz' diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 79289234..9a4bb3e1 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -3235,7 +3235,7 @@ subroutine psb_s_csr_clean_zeros(a, info) use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_clean_zeros implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nr integer(psb_ipk_), allocatable :: ilrp(:) @@ -5350,7 +5350,7 @@ subroutine psb_ls_csr_clean_zeros(a, info) use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_clean_zeros implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nr integer(psb_lpk_), allocatable :: ilrp(:) diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 7850aeec..7ea439d0 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -592,7 +592,7 @@ subroutine psb_z_coo_clean_zeros(a, info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_clean_zeros implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i,j,k, nzin @@ -5264,7 +5264,7 @@ subroutine psb_lz_coo_clean_zeros(a, info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_zeros implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i,j,k, nzin @@ -6760,7 +6760,8 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_sort_mod implicit none - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(in) :: nr, nc, nzin + integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) integer(psb_lpk_), intent(out) :: nzout diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index 457489f3..8b0ccc65 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2371,7 +2371,7 @@ subroutine psb_z_csc_clean_zeros(a, info) use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_clean_zeros implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nc integer(psb_ipk_), allocatable :: ilcp(:) @@ -4255,7 +4255,7 @@ subroutine psb_lz_csc_clean_zeros(a, info) use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_clean_zeros implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nc integer(psb_lpk_), allocatable :: ilcp(:) @@ -4319,7 +4319,7 @@ subroutine psb_lz_csc_reallocate_nz(nz,a) use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_reallocate_nz implicit none - integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: nz class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) character(len=20) :: name='lz_csc_reallocate_nz' diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 1f1025ab..bf9817ef 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -3235,7 +3235,7 @@ subroutine psb_z_csr_clean_zeros(a, info) use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_clean_zeros implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_) :: i, j, k, nr integer(psb_ipk_), allocatable :: ilrp(:) @@ -5350,7 +5350,7 @@ subroutine psb_lz_csr_clean_zeros(a, info) use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_clean_zeros implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(out) :: info ! integer(psb_lpk_) :: i, j, k, nr integer(psb_lpk_), allocatable :: ilrp(:) From 1c98111fd987e6c964d0bf2c28721f858d75c82d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 18 Jun 2021 18:42:38 +0200 Subject: [PATCH 09/15] More interface mismatch fixes --- base/internals/psi_adjcncy_fnd_owner.F90 | 2 +- base/internals/psi_sort_dl.f90 | 5 +- base/modules/auxil/psb_c_hsort_mod.f90 | 4 +- base/modules/auxil/psb_c_hsort_x_mod.f90 | 14 +- base/modules/auxil/psb_d_hsort_mod.f90 | 4 +- base/modules/auxil/psb_d_hsort_x_mod.f90 | 14 +- base/modules/auxil/psb_e_hsort_mod.f90 | 18 +- base/modules/auxil/psb_i2_hsort_mod.f90 | 4 +- base/modules/auxil/psb_i_hsort_x_mod.f90 | 14 +- base/modules/auxil/psb_l_hsort_x_mod.f90 | 14 +- base/modules/auxil/psb_m_hsort_mod.f90 | 4 +- base/modules/auxil/psb_s_hsort_mod.f90 | 4 +- base/modules/auxil/psb_s_hsort_x_mod.f90 | 14 +- base/modules/auxil/psb_z_hsort_mod.f90 | 4 +- base/modules/auxil/psb_z_hsort_x_mod.f90 | 14 +- base/modules/auxil/psi_c_serial_mod.f90 | 2 +- base/modules/auxil/psi_d_serial_mod.f90 | 2 +- base/modules/auxil/psi_e_serial_mod.f90 | 2 +- base/modules/auxil/psi_i2_serial_mod.f90 | 2 +- base/modules/auxil/psi_m_serial_mod.f90 | 2 +- base/modules/auxil/psi_s_serial_mod.f90 | 2 +- base/modules/auxil/psi_z_serial_mod.f90 | 2 +- base/modules/desc/psb_indx_map_mod.f90 | 2 +- base/modules/psi_i_mod.F90 | 8 +- base/psblas/psb_caxpby.f90 | 2 +- base/psblas/psb_daxpby.f90 | 2 +- base/psblas/psb_saxpby.f90 | 2 +- base/psblas/psb_zaxpby.f90 | 2 +- base/serial/impl/psb_c_coo_impl.F90 | 2 +- base/serial/impl/psb_d_coo_impl.F90 | 2 +- base/serial/impl/psb_s_coo_impl.F90 | 2 +- base/serial/impl/psb_z_coo_impl.F90 | 2 +- base/serial/sort/psb_c_hsort_impl.f90 | 8 +- base/serial/sort/psb_c_msort_impl.f90 | 1392 +++++++++++----------- base/serial/sort/psb_d_hsort_impl.f90 | 10 +- base/serial/sort/psb_d_msort_impl.f90 | 1100 +++++++++-------- base/serial/sort/psb_e_hsort_impl.f90 | 22 +- base/serial/sort/psb_e_msort_impl.f90 | 1200 ++++++++++--------- base/serial/sort/psb_m_hsort_impl.f90 | 10 +- base/serial/sort/psb_m_msort_impl.f90 | 1200 ++++++++++--------- base/serial/sort/psb_s_hsort_impl.f90 | 10 +- base/serial/sort/psb_s_msort_impl.f90 | 1100 +++++++++-------- base/serial/sort/psb_z_hsort_impl.f90 | 8 +- base/serial/sort/psb_z_msort_impl.f90 | 1392 +++++++++++----------- 44 files changed, 3807 insertions(+), 3818 deletions(-) diff --git a/base/internals/psi_adjcncy_fnd_owner.F90 b/base/internals/psi_adjcncy_fnd_owner.F90 index 03aa0f09..639cdb5d 100644 --- a/base/internals/psi_adjcncy_fnd_owner.F90 +++ b/base/internals/psi_adjcncy_fnd_owner.F90 @@ -71,7 +71,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) #endif integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - integer(psb_ipk_), intent(in) :: adj(:) + integer(psb_ipk_), intent(inout) :: adj(:) class(psb_indx_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index 55cc280f..ef3ac74d 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -84,9 +84,10 @@ subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ctxt,info) use psb_sort_mod implicit none - integer(psb_ipk_), intent(inout) :: c_dep_list(:), dl_ptr(0:), l_dep_list(0:) + integer(psb_ipk_), intent(in) :: dl_ptr(0:) + integer(psb_ipk_), intent(inout) :: c_dep_list(:), l_dep_list(0:) type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: dg(:), dgp(:),& & idx(:), upd(:), edges(:,:), ich(:) diff --git a/base/modules/auxil/psb_c_hsort_mod.f90 b/base/modules/auxil/psb_c_hsort_mod.f90 index 43b22ec4..e7eb2fbf 100644 --- a/base/modules/auxil/psb_c_hsort_mod.f90 +++ b/base/modules/auxil/psb_c_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_c_hsort_mod subroutine psi_c_heap_get_first(key,last,heap,dir,info) import implicit none - complex(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + complex(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir complex(psb_spk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_c_hsort_x_mod.f90 b/base/modules/auxil/psb_c_hsort_x_mod.f90 index 4331c567..c0e39411 100644 --- a/base/modules/auxil/psb_c_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_c_hsort_x_mod.f90 @@ -45,7 +45,8 @@ module psb_c_hsort_x_mod use psb_c_hsort_mod type psb_c_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last complex(psb_spk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_c_init_heap @@ -57,7 +58,8 @@ module psb_c_hsort_x_mod end type psb_c_heap type psb_c_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last complex(psb_spk_), allocatable :: keys(:) integer(psb_ipk_), allocatable :: idxs(:) contains @@ -121,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -234,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -254,7 +256,7 @@ contains class(psb_c_idx_heap), intent(inout) :: heap integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), intent(out) :: key + complex(psb_spk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psb_d_hsort_mod.f90 b/base/modules/auxil/psb_d_hsort_mod.f90 index c1a7523c..570f27b1 100644 --- a/base/modules/auxil/psb_d_hsort_mod.f90 +++ b/base/modules/auxil/psb_d_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_d_hsort_mod subroutine psi_d_heap_get_first(key,last,heap,dir,info) import implicit none - real(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + real(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir real(psb_dpk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_d_hsort_x_mod.f90 b/base/modules/auxil/psb_d_hsort_x_mod.f90 index df290e38..7273e972 100644 --- a/base/modules/auxil/psb_d_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_d_hsort_x_mod.f90 @@ -45,7 +45,8 @@ module psb_d_hsort_x_mod use psb_d_hsort_mod type psb_d_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last real(psb_dpk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_d_init_heap @@ -57,7 +58,8 @@ module psb_d_hsort_x_mod end type psb_d_heap type psb_d_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last real(psb_dpk_), allocatable :: keys(:) integer(psb_ipk_), allocatable :: idxs(:) contains @@ -121,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -234,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -254,7 +256,7 @@ contains class(psb_d_idx_heap), intent(inout) :: heap integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), intent(out) :: key + real(psb_dpk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psb_e_hsort_mod.f90 b/base/modules/auxil/psb_e_hsort_mod.f90 index 3ce7ac45..5433cec4 100644 --- a/base/modules/auxil/psb_e_hsort_mod.f90 +++ b/base/modules/auxil/psb_e_hsort_mod.f90 @@ -67,8 +67,8 @@ module psb_e_hsort_mod integer(psb_epk_), intent(in) :: key integer(psb_epk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last + integer(psb_epk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: last integer(psb_ipk_), intent(out) :: info end subroutine psi_e_insert_heap end interface psi_insert_heap @@ -88,9 +88,9 @@ module psb_e_hsort_mod integer(psb_epk_), intent(in) :: key integer(psb_epk_), intent(inout) :: heap(:) integer(psb_epk_), intent(in) :: index - integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(in) :: dir integer(psb_epk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: last + integer(psb_epk_), intent(inout) :: last integer(psb_ipk_), intent(out) :: info end subroutine psi_e_idx_insert_heap end interface psi_idx_insert_heap @@ -100,9 +100,9 @@ module psb_e_hsort_mod subroutine psi_e_heap_get_first(key,last,heap,dir,info) import implicit none - integer(psb_epk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: key + integer(psb_epk_), intent(inout) :: last + integer(psb_epk_), intent(in) :: dir integer(psb_epk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info end subroutine psi_e_heap_get_first @@ -114,8 +114,8 @@ module psb_e_hsort_mod integer(psb_epk_), intent(inout) :: key integer(psb_epk_), intent(out) :: index integer(psb_epk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last + integer(psb_epk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: last integer(psb_epk_), intent(inout) :: idxs(:) integer(psb_ipk_), intent(out) :: info end subroutine psi_e_idx_heap_get_first diff --git a/base/modules/auxil/psb_i2_hsort_mod.f90 b/base/modules/auxil/psb_i2_hsort_mod.f90 index 0878f86e..6a6c96de 100644 --- a/base/modules/auxil/psb_i2_hsort_mod.f90 +++ b/base/modules/auxil/psb_i2_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_i2_hsort_mod subroutine psi_i2_heap_get_first(key,last,heap,dir,info) import implicit none - integer(psb_i2pk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + integer(psb_i2pk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir integer(psb_i2pk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_i_hsort_x_mod.f90 b/base/modules/auxil/psb_i_hsort_x_mod.f90 index cf148d20..0d1288a6 100644 --- a/base/modules/auxil/psb_i_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_i_hsort_x_mod.f90 @@ -46,7 +46,8 @@ module psb_i_hsort_x_mod use psb_m_hsort_mod type psb_i_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last integer(psb_ipk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_i_init_heap @@ -58,7 +59,8 @@ module psb_i_hsort_x_mod end type psb_i_heap type psb_i_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last integer(psb_ipk_), allocatable :: keys(:) integer(psb_ipk_), allocatable :: idxs(:) contains @@ -122,7 +124,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -235,9 +237,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -255,7 +257,7 @@ contains class(psb_i_idx_heap), intent(inout) :: heap integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(out) :: key + integer(psb_ipk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psb_l_hsort_x_mod.f90 b/base/modules/auxil/psb_l_hsort_x_mod.f90 index bf9bd435..487e8ce9 100644 --- a/base/modules/auxil/psb_l_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_l_hsort_x_mod.f90 @@ -46,7 +46,8 @@ module psb_l_hsort_x_mod use psb_m_hsort_mod type psb_l_heap - integer(psb_ipk_) :: last, dir + integer(psb_lpk_) :: dir + integer(psb_lpk_) :: last integer(psb_lpk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_l_init_heap @@ -58,7 +59,8 @@ module psb_l_hsort_x_mod end type psb_l_heap type psb_l_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_lpk_) :: dir + integer(psb_lpk_) :: last integer(psb_lpk_), allocatable :: keys(:) integer(psb_lpk_), allocatable :: idxs(:) contains @@ -122,7 +124,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_lpk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -235,9 +237,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_lpk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_lpk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -255,7 +257,7 @@ contains class(psb_l_idx_heap), intent(inout) :: heap integer(psb_lpk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(out) :: key + integer(psb_lpk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psb_m_hsort_mod.f90 b/base/modules/auxil/psb_m_hsort_mod.f90 index e2d7aef6..22ffdf34 100644 --- a/base/modules/auxil/psb_m_hsort_mod.f90 +++ b/base/modules/auxil/psb_m_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_m_hsort_mod subroutine psi_m_heap_get_first(key,last,heap,dir,info) import implicit none - integer(psb_mpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + integer(psb_mpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir integer(psb_mpk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_s_hsort_mod.f90 b/base/modules/auxil/psb_s_hsort_mod.f90 index 3d30bafd..4cee5508 100644 --- a/base/modules/auxil/psb_s_hsort_mod.f90 +++ b/base/modules/auxil/psb_s_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_s_hsort_mod subroutine psi_s_heap_get_first(key,last,heap,dir,info) import implicit none - real(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + real(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir real(psb_spk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_s_hsort_x_mod.f90 b/base/modules/auxil/psb_s_hsort_x_mod.f90 index 3b395fb1..34f69ea4 100644 --- a/base/modules/auxil/psb_s_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_s_hsort_x_mod.f90 @@ -45,7 +45,8 @@ module psb_s_hsort_x_mod use psb_s_hsort_mod type psb_s_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last real(psb_spk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_s_init_heap @@ -57,7 +58,8 @@ module psb_s_hsort_x_mod end type psb_s_heap type psb_s_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last real(psb_spk_), allocatable :: keys(:) integer(psb_ipk_), allocatable :: idxs(:) contains @@ -121,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -234,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -254,7 +256,7 @@ contains class(psb_s_idx_heap), intent(inout) :: heap integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - real(psb_spk_), intent(out) :: key + real(psb_spk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psb_z_hsort_mod.f90 b/base/modules/auxil/psb_z_hsort_mod.f90 index 573eef6b..98e47da2 100644 --- a/base/modules/auxil/psb_z_hsort_mod.f90 +++ b/base/modules/auxil/psb_z_hsort_mod.f90 @@ -100,8 +100,8 @@ module psb_z_hsort_mod subroutine psi_z_heap_get_first(key,last,heap,dir,info) import implicit none - complex(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last + complex(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(in) :: dir complex(psb_dpk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/auxil/psb_z_hsort_x_mod.f90 b/base/modules/auxil/psb_z_hsort_x_mod.f90 index fc0edd9b..39f52e4f 100644 --- a/base/modules/auxil/psb_z_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_z_hsort_x_mod.f90 @@ -45,7 +45,8 @@ module psb_z_hsort_x_mod use psb_z_hsort_mod type psb_z_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last complex(psb_dpk_), allocatable :: keys(:) contains procedure, pass(heap) :: init => psb_z_init_heap @@ -57,7 +58,8 @@ module psb_z_hsort_x_mod end type psb_z_heap type psb_z_idx_heap - integer(psb_ipk_) :: last, dir + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last complex(psb_dpk_), allocatable :: keys(:) integer(psb_ipk_), allocatable :: idxs(:) contains @@ -121,7 +123,7 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -234,9 +236,9 @@ contains return endif - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info == psb_success_) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=(1_psb_ipk_)*psb_heap_resize) if (info /= psb_success_) then write(psb_err_unit,*) 'Memory allocation failure in heap_insert' info = -5 @@ -254,7 +256,7 @@ contains class(psb_z_idx_heap), intent(inout) :: heap integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), intent(out) :: key + complex(psb_dpk_), intent(inout) :: key info = psb_success_ diff --git a/base/modules/auxil/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 index f017f350..191e7ef3 100644 --- a/base/modules/auxil/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_c_serial_mod integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent (in) :: x(:) complex(psb_spk_), intent (in) :: y(:) - complex(psb_spk_), intent (in) :: z(:) + complex(psb_spk_), intent (inout) :: z(:) complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_caxpbyv2 diff --git a/base/modules/auxil/psi_d_serial_mod.f90 b/base/modules/auxil/psi_d_serial_mod.f90 index c27aa600..f1dbc16c 100644 --- a/base/modules/auxil/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_d_serial_mod integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent (in) :: x(:) real(psb_dpk_), intent (in) :: y(:) - real(psb_dpk_), intent (in) :: z(:) + real(psb_dpk_), intent (inout) :: z(:) real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_daxpbyv2 diff --git a/base/modules/auxil/psi_e_serial_mod.f90 b/base/modules/auxil/psi_e_serial_mod.f90 index 99a91985..909b025c 100644 --- a/base/modules/auxil/psi_e_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_e_serial_mod integer(psb_ipk_), intent(in) :: m integer(psb_epk_), intent (in) :: x(:) integer(psb_epk_), intent (in) :: y(:) - integer(psb_epk_), intent (in) :: z(:) + integer(psb_epk_), intent (inout) :: z(:) integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_eaxpbyv2 diff --git a/base/modules/auxil/psi_i2_serial_mod.f90 b/base/modules/auxil/psi_i2_serial_mod.f90 index 565955e7..38ef9c38 100644 --- a/base/modules/auxil/psi_i2_serial_mod.f90 +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_i2_serial_mod integer(psb_ipk_), intent(in) :: m integer(psb_i2pk_), intent (in) :: x(:) integer(psb_i2pk_), intent (in) :: y(:) - integer(psb_i2pk_), intent (in) :: z(:) + integer(psb_i2pk_), intent (inout) :: z(:) integer(psb_i2pk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_i2axpbyv2 diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 index 17ea8dc4..a80d0ffe 100644 --- a/base/modules/auxil/psi_m_serial_mod.f90 +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_m_serial_mod integer(psb_ipk_), intent(in) :: m integer(psb_mpk_), intent (in) :: x(:) integer(psb_mpk_), intent (in) :: y(:) - integer(psb_mpk_), intent (in) :: z(:) + integer(psb_mpk_), intent (inout) :: z(:) integer(psb_mpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_maxpbyv2 diff --git a/base/modules/auxil/psi_s_serial_mod.f90 b/base/modules/auxil/psi_s_serial_mod.f90 index ed7b5d9f..3c0a3bdc 100644 --- a/base/modules/auxil/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_s_serial_mod integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent (in) :: x(:) real(psb_spk_), intent (in) :: y(:) - real(psb_spk_), intent (in) :: z(:) + real(psb_spk_), intent (inout) :: z(:) real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_saxpbyv2 diff --git a/base/modules/auxil/psi_z_serial_mod.f90 b/base/modules/auxil/psi_z_serial_mod.f90 index 9de8451b..7bc9728e 100644 --- a/base/modules/auxil/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -93,7 +93,7 @@ module psi_z_serial_mod integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent (in) :: x(:) complex(psb_dpk_), intent (in) :: y(:) - complex(psb_dpk_), intent (in) :: z(:) + complex(psb_dpk_), intent (inout) :: z(:) complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_zaxpbyv2 diff --git a/base/modules/desc/psb_indx_map_mod.f90 b/base/modules/desc/psb_indx_map_mod.f90 index 0c0d8199..79526d59 100644 --- a/base/modules/desc/psb_indx_map_mod.f90 +++ b/base/modules/desc/psb_indx_map_mod.f90 @@ -296,7 +296,7 @@ module psb_indx_map_mod implicit none integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - integer(psb_ipk_), allocatable, intent(inout) :: adj(:) + integer(psb_ipk_), intent(inout) :: adj(:) class(psb_indx_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info end subroutine psi_adjcncy_fnd_owner diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index 7310065a..e852dd99 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -87,10 +87,10 @@ module psi_i_mod subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ctxt,info) import implicit none - integer(psb_ipk_), intent(in) :: c_dep_list(:), dl_ptr(0:) - integer(psb_ipk_), intent(inout) :: l_dep_list(0:) - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: info + integer(psb_ipk_), intent(in) :: dl_ptr(0:) + integer(psb_ipk_), intent(inout) :: c_dep_list(:), l_dep_list(0:) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info end subroutine psi_i_csr_sort_dl end interface diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 9ac48603..da3dd93b 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -642,7 +642,7 @@ subroutine psb_caxpbyvout(alpha, x, beta,y, z, desc_a,info) end if if(desc_a%get_local_rows() > 0) then - call caxpby(desc_a%get_local_cols(),ione,& + call caxpbyv2(desc_a%get_local_cols(),ione,& & alpha,x,lldx,beta,& & y,lldy,z,lldz,info) end if diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index f2768789..c386f8f2 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -642,7 +642,7 @@ subroutine psb_daxpbyvout(alpha, x, beta,y, z, desc_a,info) end if if(desc_a%get_local_rows() > 0) then - call daxpby(desc_a%get_local_cols(),ione,& + call daxpbyv2(desc_a%get_local_cols(),ione,& & alpha,x,lldx,beta,& & y,lldy,z,lldz,info) end if diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index 774c1ad7..78f4d01a 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -642,7 +642,7 @@ subroutine psb_saxpbyvout(alpha, x, beta,y, z, desc_a,info) end if if(desc_a%get_local_rows() > 0) then - call saxpby(desc_a%get_local_cols(),ione,& + call saxpbyv2(desc_a%get_local_cols(),ione,& & alpha,x,lldx,beta,& & y,lldy,z,lldz,info) end if diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 1165ea8a..2258f38f 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -642,7 +642,7 @@ subroutine psb_zaxpbyvout(alpha, x, beta,y, z, desc_a,info) end if if(desc_a%get_local_rows() > 0) then - call zaxpby(desc_a%get_local_cols(),ione,& + call zaxpbyv2(desc_a%get_local_cols(),ione,& & alpha,x,lldx,beta,& & y,lldy,z,lldz,info) end if diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 442b2a48..bd03b1b8 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -4616,7 +4616,7 @@ function psb_lc_coo_csnm1(a) result(res) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnm1 implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 88c1ef16..d4d88027 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -4616,7 +4616,7 @@ function psb_ld_coo_csnm1(a) result(res) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnm1 implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index 5a0a3279..5ae9dd96 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -4616,7 +4616,7 @@ function psb_ls_coo_csnm1(a) result(res) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnm1 implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 7ea439d0..49e6c7fe 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -4616,7 +4616,7 @@ function psb_lz_coo_csnm1(a) result(res) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnm1 implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info diff --git a/base/serial/sort/psb_c_hsort_impl.f90 b/base/serial/sort/psb_c_hsort_impl.f90 index 8a5fe3c7..c68ec73b 100644 --- a/base/serial/sort/psb_c_hsort_impl.f90 +++ b/base/serial/sort/psb_c_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_chsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_ipk_) :: dir_, l complex(psb_spk_) :: key integer(psb_ipk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_chsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -646,7 +647,8 @@ subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info) ! dir: sorting direction complex(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir complex(psb_spk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(inout) :: idxs(:) integer(psb_ipk_), intent(inout) :: last diff --git a/base/serial/sort/psb_c_msort_impl.f90 b/base/serial/sort/psb_c_msort_impl.f90 index fa87a425..751f6098 100644 --- a/base/serial/sort/psb_c_msort_impl.f90 +++ b/base/serial/sort/psb_c_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -41,777 +41,771 @@ ! Addison-Wesley ! - subroutine psb_cmsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_cmsort_u - use psb_error_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir +subroutine psb_cmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_cmsort_u + use psb_error_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - integer(psb_ipk_) :: n, k - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) + name='psb_msort_u' + call psb_erractionsave(err_act) - n = size(x) + n = size(x) - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo - return + return 9999 call psb_error_handler(err_act) - return - end subroutine psb_cmsort_u - - - - - - - - - subroutine psb_cmsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_cmsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_ipk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_cmsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ + return +end subroutine psb_cmsort_u + + +subroutine psb_cmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_cmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_cmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + select case(dir_) + case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,& + & psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ end if - select case(dir_) - case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,& - & psb_asort_up_, psb_asort_down_) + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_c_msort') + goto 9999 + endif + + select case(dir_) + case (psb_lsort_up_) + call psi_c_lmsort_up(n,x,iaux,iret) + case (psb_lsort_down_) + call psi_c_lmsort_dw(n,x,iaux,iret) + case (psb_alsort_up_) + call psi_c_almsort_up(n,x,iaux,iret) + case (psb_alsort_down_) + call psi_c_almsort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_c_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_c_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_c_msort') - goto 9999 - endif + return - select case(dir_) - case (psb_lsort_up_) - call psi_c_lmsort_up(n,x,iaux,iret) - case (psb_lsort_down_) - call psi_c_lmsort_dw(n,x,iaux,iret) - case (psb_alsort_up_) - call psi_c_almsort_up(n,x,iaux,iret) - case (psb_alsort_down_) - call psi_c_almsort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_c_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_c_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if - end if +9999 call psb_error_handler(err_act) - return + return -9999 call psb_error_handler(err_act) - return - - - end subroutine psb_cmsort - - subroutine psi_c_lmsort_up(n,k,l,iret) - use psb_const_mod - use psi_lcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_cmsort + +subroutine psi_c_lmsort_up(n,k,l,iret) + use psb_const_mod + use psi_lcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_c_lmsort_up - - subroutine psi_c_lmsort_dw(n,k,l,iret) - use psb_const_mod - use psi_lcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_c_lmsort_up + +subroutine psi_c_lmsort_dw(n,k,l,iret) + use psb_const_mod + use psi_lcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_c_lmsort_dw - - subroutine psi_c_amsort_up(n,k,l,iret) - use psb_const_mod - use psi_acx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_c_lmsort_dw + +subroutine psi_c_amsort_up(n,k,l,iret) + use psb_const_mod + use psi_acx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_c_amsort_up - - subroutine psi_c_amsort_dw(n,k,l,iret) - use psb_const_mod - use psi_acx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_c_amsort_up + +subroutine psi_c_amsort_dw(n,k,l,iret) + use psb_const_mod + use psi_acx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_c_amsort_dw - - subroutine psi_c_almsort_up(n,k,l,iret) - use psb_const_mod - use psi_alcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_c_amsort_dw + +subroutine psi_c_almsort_up(n,k,l,iret) + use psb_const_mod + use psi_alcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_c_almsort_up - - subroutine psi_c_almsort_dw(n,k,l,iret) - use psb_const_mod - use psi_alcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_c_almsort_up + +subroutine psi_c_almsort_dw(n,k,l,iret) + use psb_const_mod + use psi_alcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - end subroutine psi_c_almsort_dw +end subroutine psi_c_almsort_dw diff --git a/base/serial/sort/psb_d_hsort_impl.f90 b/base/serial/sort/psb_d_hsort_impl.f90 index b83e93cc..ffb952d5 100644 --- a/base/serial/sort/psb_d_hsort_impl.f90 +++ b/base/serial/sort/psb_d_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_dhsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_ipk_) :: dir_, l real(psb_dpk_) :: key integer(psb_ipk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_dhsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -540,11 +541,12 @@ subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info) use psb_sort_mod, psb_protect_name => psi_d_idx_heap_get_first implicit none + real(psb_dpk_), intent(inout) :: key real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(inout) :: last,idxs(:) integer(psb_ipk_), intent(in) :: dir - real(psb_dpk_), intent(out) :: key integer(psb_ipk_) :: i, j,itemp real(psb_dpk_) :: temp diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 index 01491b0b..11029818 100644 --- a/base/serial/sort/psb_d_msort_impl.f90 +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -41,618 +41,612 @@ ! Addison-Wesley ! - subroutine psb_dmsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_dmsort_u - use psb_error_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir +subroutine psb_dmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_dmsort_u + use psb_error_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - integer(psb_ipk_) :: n, k - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) + name='psb_msort_u' + call psb_erractionsave(err_act) - n = size(x) + n = size(x) - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo - return + return 9999 call psb_error_handler(err_act) - return - end subroutine psb_dmsort_u + return +end subroutine psb_dmsort_u - function psb_dbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_dbsrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) +function psb_dbsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_dbsrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) - integer(psb_ipk_) :: lb, ub, m, i + integer(psb_ipk_) :: lb, ub, m, i - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return - end function psb_dbsrch - - function psb_dssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_dssrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 + ipos = -1 + if (n<5) then do i=1,n if (key.eq.v(i)) then ipos = i return end if enddo - return - end function psb_dssrch - - subroutine psb_dmsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_dmsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_ipk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_dmsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + enddo + return +end function psb_dbsrch + +function psb_dssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_dssrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_dssrch + +subroutine psb_dmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_dmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_dmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select - - end if - - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_d_msort') - goto 9999 - endif - - select case(dir_) - case (psb_sort_up_) - call psi_d_msort_up(n,x,iaux,iret) - case (psb_sort_down_) - call psi_d_msort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_d_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_d_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_d_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_d_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_d_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_d_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_d_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - return + return 9999 call psb_error_handler(err_act) - return + return - end subroutine psb_dmsort - - subroutine psi_d_msort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_dmsort + +subroutine psi_d_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do - - if (k(p) > k(q)) then - - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) > k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) <= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_d_msort_up - - subroutine psi_d_msort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_d_msort_up - if (k(p) < k(q)) then +subroutine psi_d_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) < k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) >= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_d_msort_dw - - subroutine psi_d_amsort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) <= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_d_msort_dw - if (abs(k(p)) > abs(k(q))) then +subroutine psi_d_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) <= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) > abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) > abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_d_amsort_up - - subroutine psi_d_amsort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) >= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_d_amsort_up - if (abs(k(p)) < abs(k(q))) then +subroutine psi_d_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) >= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) < abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) < abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_d_amsort_dw - - - + else + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass +end subroutine psi_d_amsort_dw diff --git a/base/serial/sort/psb_e_hsort_impl.f90 b/base/serial/sort/psb_e_hsort_impl.f90 index d6990f36..f1a1a78f 100644 --- a/base/serial/sort/psb_e_hsort_impl.f90 +++ b/base/serial/sort/psb_e_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_ehsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_epk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_epk_) :: dir_, l integer(psb_epk_) :: key integer(psb_epk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_ehsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -196,7 +197,7 @@ subroutine psi_e_insert_heap(key,last,heap,dir,info) ! dir: sorting direction integer(psb_epk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(in) :: dir integer(psb_epk_), intent(inout) :: heap(:) integer(psb_epk_), intent(inout) :: last integer(psb_ipk_), intent(out) :: info @@ -296,7 +297,7 @@ subroutine psi_e_heap_get_first(key,last,heap,dir,info) integer(psb_epk_), intent(inout) :: key integer(psb_epk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(in) :: dir integer(psb_epk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(out) :: info @@ -428,9 +429,9 @@ subroutine psi_e_idx_insert_heap(key,index,last,heap,idxs,dir,info) ! dir: sorting direction integer(psb_epk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir + integer(psb_epk_), intent(in) :: index,dir integer(psb_epk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: idxs(:),last + integer(psb_epk_), intent(inout) :: idxs(:),last integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, i2, itemp integer(psb_epk_) :: temp @@ -540,11 +541,12 @@ subroutine psi_e_idx_heap_get_first(key,index,last,heap,idxs,dir,info) use psb_sort_mod, psb_protect_name => psi_e_idx_heap_get_first implicit none + integer(psb_epk_), intent(inout) :: key integer(psb_epk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_epk_), intent(out) :: key + integer(psb_epk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(inout) :: last,idxs(:) + integer(psb_epk_), intent(in) :: dir integer(psb_ipk_) :: i, j,itemp integer(psb_epk_) :: temp diff --git a/base/serial/sort/psb_e_msort_impl.f90 b/base/serial/sort/psb_e_msort_impl.f90 index 2950d7bd..d8cd6404 100644 --- a/base/serial/sort/psb_e_msort_impl.f90 +++ b/base/serial/sort/psb_e_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -40,674 +40,668 @@ ! Data Structures and Algorithms ! Addison-Wesley ! - logical function psb_eisaperm(n,eip) - use psb_sort_mod, psb_protect_name => psb_eisaperm - implicit none - - integer(psb_epk_), intent(in) :: n - integer(psb_epk_), intent(in) :: eip(n) - integer(psb_epk_), allocatable :: ip(:) - integer(psb_epk_) :: i,j,m, info - - - psb_eisaperm = .true. - if (n <= 0) return - allocate(ip(n), stat=info) - if (info /= psb_success_) return - ! - ! sanity check first - ! - do i=1, n - ip(i) = eip(i) - if ((ip(i) < 1).or.(ip(i) > n)) then - write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n - psb_eisaperm = .false. - return - endif - enddo +logical function psb_eisaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_eisaperm + implicit none - ! - ! now work through the cycles, by marking each successive item as negative. - ! no cycle should intersect with any other, hence the >= 1 check. - ! - do m = 1, n - i = ip(m) - if (i < 0) then - ip(m) = -i - else if (i /= m) then - j = ip(i) - ip(i) = -j - i = j - do while ((j >= 1).and.(j /= m)) - j = ip(i) - ip(i) = -j - i = j - enddo - ip(m) = abs(ip(m)) - if (j /= m) then - psb_eisaperm = .false. - goto 9999 - endif - end if - enddo -9999 continue + integer(psb_epk_), intent(in) :: n + integer(psb_epk_), intent(in) :: eip(n) + integer(psb_epk_), allocatable :: ip(:) + integer(psb_epk_) :: i,j,m, info - return - end function psb_eisaperm + psb_eisaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_eisaperm = .false. + return + endif + enddo - subroutine psb_emsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_emsort_u - use psb_error_mod - implicit none - integer(psb_epk_), intent(inout) :: x(:) - integer(psb_epk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_eisaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue - integer(psb_epk_) :: n, k - integer(psb_ipk_) :: err_act + return +end function psb_eisaperm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) +subroutine psb_emsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_emsort_u + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - n = size(x) + integer(psb_epk_) :: n, k + integer(psb_ipk_) :: err_act - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - return + name='psb_msort_u' + call psb_erractionsave(err_act) -9999 call psb_error_handler(err_act) + n = size(x) - return - end subroutine psb_emsort_u + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + return - function psb_ebsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_ebsrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_epk_) :: key - integer(psb_epk_) :: v(:) +9999 call psb_error_handler(err_act) - integer(psb_ipk_) :: lb, ub, m, i + return +end subroutine psb_emsort_u - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return - end function psb_ebsrch - function psb_essrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_essrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_epk_) :: key - integer(psb_epk_) :: v(:) +function psb_ebsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_ebsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) - integer(psb_ipk_) :: i + integer(psb_ipk_) :: lb, ub, m, i - ipos = -1 + ipos = -1 + if (n<5) then do i=1,n if (key.eq.v(i)) then ipos = i return end if enddo - return - end function psb_essrch - - subroutine psb_emsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_emsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - integer(psb_epk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_epk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_epk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_emsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + enddo + return +end function psb_ebsrch + +function psb_essrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_essrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_essrch + +subroutine psb_emsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_emsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_epk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_emsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select - - end if - - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_e_msort') - goto 9999 - endif - - select case(dir_) - case (psb_sort_up_) - call psi_e_msort_up(n,x,iaux,iret) - case (psb_sort_down_) - call psi_e_msort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_e_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_e_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_e_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_e_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_e_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_e_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_e_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - return + return 9999 call psb_error_handler(err_act) - return + return - end subroutine psb_emsort - - subroutine psi_e_msort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_epk_) :: k(n) - integer(psb_epk_) :: l(0:n+1) - ! - integer(psb_epk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_emsort + +subroutine psi_e_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit - end do - - else - - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t - do - t = q + if (k(p) <= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_e_msort_up - - subroutine psi_e_msort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_epk_) :: k(n) - integer(psb_epk_) :: l(0:n+1) - ! - integer(psb_epk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_e_msort_up - if (k(p) < k(q)) then +subroutine psi_e_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) < k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) >= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_e_msort_dw - - subroutine psi_e_amsort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_epk_) :: k(n) - integer(psb_epk_) :: l(0:n+1) - ! - integer(psb_epk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) <= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_e_msort_dw - if (abs(k(p)) > abs(k(q))) then +subroutine psi_e_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) <= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) > abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) > abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_e_amsort_up - - subroutine psi_e_amsort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_epk_) :: k(n) - integer(psb_epk_) :: l(0:n+1) - ! - integer(psb_epk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) >= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_e_amsort_up - if (abs(k(p)) < abs(k(q))) then +subroutine psi_e_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) >= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) < abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) < abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_e_amsort_dw - - - + else + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass +end subroutine psi_e_amsort_dw diff --git a/base/serial/sort/psb_m_hsort_impl.f90 b/base/serial/sort/psb_m_hsort_impl.f90 index dad77210..5dc92082 100644 --- a/base/serial/sort/psb_m_hsort_impl.f90 +++ b/base/serial/sort/psb_m_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_mhsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_ipk_) :: dir_, l integer(psb_mpk_) :: key integer(psb_ipk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_mhsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -540,11 +541,12 @@ subroutine psi_m_idx_heap_get_first(key,index,last,heap,idxs,dir,info) use psb_sort_mod, psb_protect_name => psi_m_idx_heap_get_first implicit none + integer(psb_mpk_), intent(inout) :: key integer(psb_mpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(inout) :: last,idxs(:) integer(psb_ipk_), intent(in) :: dir - integer(psb_mpk_), intent(out) :: key integer(psb_ipk_) :: i, j,itemp integer(psb_mpk_) :: temp diff --git a/base/serial/sort/psb_m_msort_impl.f90 b/base/serial/sort/psb_m_msort_impl.f90 index abbe4049..cd99a3c5 100644 --- a/base/serial/sort/psb_m_msort_impl.f90 +++ b/base/serial/sort/psb_m_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -40,674 +40,668 @@ ! Data Structures and Algorithms ! Addison-Wesley ! - logical function psb_misaperm(n,eip) - use psb_sort_mod, psb_protect_name => psb_misaperm - implicit none - - integer(psb_mpk_), intent(in) :: n - integer(psb_mpk_), intent(in) :: eip(n) - integer(psb_mpk_), allocatable :: ip(:) - integer(psb_mpk_) :: i,j,m, info - - - psb_misaperm = .true. - if (n <= 0) return - allocate(ip(n), stat=info) - if (info /= psb_success_) return - ! - ! sanity check first - ! - do i=1, n - ip(i) = eip(i) - if ((ip(i) < 1).or.(ip(i) > n)) then - write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n - psb_misaperm = .false. - return - endif - enddo +logical function psb_misaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_misaperm + implicit none - ! - ! now work through the cycles, by marking each successive item as negative. - ! no cycle should intersect with any other, hence the >= 1 check. - ! - do m = 1, n - i = ip(m) - if (i < 0) then - ip(m) = -i - else if (i /= m) then - j = ip(i) - ip(i) = -j - i = j - do while ((j >= 1).and.(j /= m)) - j = ip(i) - ip(i) = -j - i = j - enddo - ip(m) = abs(ip(m)) - if (j /= m) then - psb_misaperm = .false. - goto 9999 - endif - end if - enddo -9999 continue + integer(psb_mpk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: eip(n) + integer(psb_mpk_), allocatable :: ip(:) + integer(psb_mpk_) :: i,j,m, info - return - end function psb_misaperm + psb_misaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_misaperm = .false. + return + endif + enddo - subroutine psb_mmsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_mmsort_u - use psb_error_mod - implicit none - integer(psb_mpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_misaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue - integer(psb_ipk_) :: n, k - integer(psb_ipk_) :: err_act + return +end function psb_misaperm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) +subroutine psb_mmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_mmsort_u + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - n = size(x) + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - return + name='psb_msort_u' + call psb_erractionsave(err_act) -9999 call psb_error_handler(err_act) + n = size(x) - return - end subroutine psb_mmsort_u + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + return - function psb_mbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_mbsrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_mpk_) :: key - integer(psb_mpk_) :: v(:) +9999 call psb_error_handler(err_act) - integer(psb_ipk_) :: lb, ub, m, i + return +end subroutine psb_mmsort_u - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return - end function psb_mbsrch - function psb_mssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_mssrch - implicit none - integer(psb_ipk_) :: ipos, n - integer(psb_mpk_) :: key - integer(psb_mpk_) :: v(:) +function psb_mbsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mbsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) - integer(psb_ipk_) :: i + integer(psb_ipk_) :: lb, ub, m, i - ipos = -1 + ipos = -1 + if (n<5) then do i=1,n if (key.eq.v(i)) then ipos = i return end if enddo - return - end function psb_mssrch - - subroutine psb_mmsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_mmsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - integer(psb_mpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_ipk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_mmsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + enddo + return +end function psb_mbsrch + +function psb_mssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mssrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_mssrch + +subroutine psb_mmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_mmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_mmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select - - end if - - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_m_msort') - goto 9999 - endif - - select case(dir_) - case (psb_sort_up_) - call psi_m_msort_up(n,x,iaux,iret) - case (psb_sort_down_) - call psi_m_msort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_m_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_m_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_m_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_m_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_m_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_m_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_m_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - return + return 9999 call psb_error_handler(err_act) - return + return - end subroutine psb_mmsort - - subroutine psi_m_msort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_mpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_mmsort + +subroutine psi_m_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit - end do - - else - - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t - do - t = q + if (k(p) <= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_m_msort_up - - subroutine psi_m_msort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_mpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_m_msort_up - if (k(p) < k(q)) then +subroutine psi_m_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) < k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) >= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_m_msort_dw - - subroutine psi_m_amsort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_mpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) <= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_m_msort_dw - if (abs(k(p)) > abs(k(q))) then +subroutine psi_m_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) <= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) > abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) > abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_m_amsort_up - - subroutine psi_m_amsort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - integer(psb_mpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) >= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_m_amsort_up - if (abs(k(p)) < abs(k(q))) then +subroutine psi_m_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) >= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) < abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) < abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_m_amsort_dw - - - + else + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass +end subroutine psi_m_amsort_dw diff --git a/base/serial/sort/psb_s_hsort_impl.f90 b/base/serial/sort/psb_s_hsort_impl.f90 index 4737d159..77fefe14 100644 --- a/base/serial/sort/psb_s_hsort_impl.f90 +++ b/base/serial/sort/psb_s_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_shsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_ipk_) :: dir_, l real(psb_spk_) :: key integer(psb_ipk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_shsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -540,11 +541,12 @@ subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info) use psb_sort_mod, psb_protect_name => psi_s_idx_heap_get_first implicit none + real(psb_spk_), intent(inout) :: key real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(inout) :: last,idxs(:) integer(psb_ipk_), intent(in) :: dir - real(psb_spk_), intent(out) :: key integer(psb_ipk_) :: i, j,itemp real(psb_spk_) :: temp diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 index a1af2f56..dfd7508c 100644 --- a/base/serial/sort/psb_s_msort_impl.f90 +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -41,618 +41,612 @@ ! Addison-Wesley ! - subroutine psb_smsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_smsort_u - use psb_error_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir +subroutine psb_smsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_smsort_u + use psb_error_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - integer(psb_ipk_) :: n, k - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) + name='psb_msort_u' + call psb_erractionsave(err_act) - n = size(x) + n = size(x) - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo - return + return 9999 call psb_error_handler(err_act) - return - end subroutine psb_smsort_u + return +end subroutine psb_smsort_u - function psb_sbsrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_sbsrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) +function psb_sbsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_sbsrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) - integer(psb_ipk_) :: lb, ub, m, i + integer(psb_ipk_) :: lb, ub, m, i - ipos = -1 - if (n<5) then - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end if - - lb = 1 - ub = n - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return - end function psb_sbsrch - - function psb_sssrch(key,n,v) result(ipos) - use psb_sort_mod, psb_protect_name => psb_sssrch - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) - - integer(psb_ipk_) :: i - - ipos = -1 + ipos = -1 + if (n<5) then do i=1,n if (key.eq.v(i)) then ipos = i return end if enddo - return - end function psb_sssrch - - subroutine psb_smsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_smsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_ipk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_smsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + enddo + return +end function psb_sbsrch + +function psb_sssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_sssrch + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_sssrch + +subroutine psb_smsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_smsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_smsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select - - end if - - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_s_msort') - goto 9999 - endif - - select case(dir_) - case (psb_sort_up_) - call psi_s_msort_up(n,x,iaux,iret) - case (psb_sort_down_) - call psi_s_msort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_s_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_s_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_s_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_s_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_s_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_s_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_s_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - return + return 9999 call psb_error_handler(err_act) - return + return - end subroutine psb_smsort - - subroutine psi_s_msort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_smsort + +subroutine psi_s_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do - - if (k(p) > k(q)) then - - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) > k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) <= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_s_msort_up - - subroutine psi_s_msort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_s_msort_up - if (k(p) < k(q)) then +subroutine psi_s_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (k(p) < k(q)) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (k(p) >= k(q)) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_s_msort_dw - - subroutine psi_s_amsort_up(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) <= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_s_msort_dw - if (abs(k(p)) > abs(k(q))) then +subroutine psi_s_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) <= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) > abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) > abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do end if - end do outer - end do mergepass - - end subroutine psi_s_amsort_up - - subroutine psi_s_amsort_dw(n,k,l,iret) - use psb_const_mod - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (abs(k(p)) >= abs(k(p+1))) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return - else - l(n+1) = abs(l(n+1)) - end if - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - outer: do +end subroutine psi_s_amsort_up - if (abs(k(p)) < abs(k(q))) then +subroutine psi_s_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (abs(k(p)) >= abs(k(q))) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t - do - t = p - p = l(p) - if (p <= 0) exit - end do + outer: do - else + if (abs(k(p)) < abs(k(q))) then - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (abs(k(p)) < abs(k(q))) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = q + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q q = l(q) if (q <= 0) exit end do end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_s_amsort_dw - - - + else + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass +end subroutine psi_s_amsort_dw diff --git a/base/serial/sort/psb_z_hsort_impl.f90 b/base/serial/sort/psb_z_hsort_impl.f90 index 7223e211..199f5663 100644 --- a/base/serial/sort/psb_z_hsort_impl.f90 +++ b/base/serial/sort/psb_z_hsort_impl.f90 @@ -49,7 +49,8 @@ subroutine psb_zhsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_ipk_) :: flag_, n, i, err_act,info + integer(psb_ipk_) :: dir_, l complex(psb_dpk_) :: key integer(psb_ipk_) :: index @@ -159,7 +160,7 @@ end subroutine psb_zhsort ! ! These are packaged so that they can be used to implement -! a heapsort, should the need arise +! a heapsort. ! ! ! Programming note: @@ -646,7 +647,8 @@ subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info) ! dir: sorting direction complex(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir complex(psb_dpk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(inout) :: idxs(:) integer(psb_ipk_), intent(inout) :: last diff --git a/base/serial/sort/psb_z_msort_impl.f90 b/base/serial/sort/psb_z_msort_impl.f90 index e885176e..525ed572 100644 --- a/base/serial/sort/psb_z_msort_impl.f90 +++ b/base/serial/sort/psb_z_msort_impl.f90 @@ -1,34 +1,34 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! 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. + ! + ! ! ! The merge-sort routines ! References: @@ -41,777 +41,771 @@ ! Addison-Wesley ! - subroutine psb_zmsort_u(x,nout,dir) - use psb_sort_mod, psb_protect_name => psb_zmsort_u - use psb_error_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir +subroutine psb_zmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_zmsort_u + use psb_error_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir - integer(psb_ipk_) :: n, k - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - name='psb_msort_u' - call psb_erractionsave(err_act) + name='psb_msort_u' + call psb_erractionsave(err_act) - n = size(x) + n = size(x) - call psb_msort(x,dir=dir) - nout = min(1,n) - do k=2,n - if (x(k) /= x(nout)) then - nout = nout + 1 - x(nout) = x(k) - endif - enddo + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo - return + return 9999 call psb_error_handler(err_act) - return - end subroutine psb_zmsort_u - - - - - - - - - subroutine psb_zmsort(x,ix,dir,flag) - use psb_sort_mod, psb_protect_name => psb_zmsort - use psb_error_mod - use psb_ip_reord_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - - integer(psb_ipk_) :: dir_, flag_, n, err_act - - integer(psb_ipk_), allocatable :: iaux(:) - integer(psb_ipk_) :: iret, info, i - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - name='psb_zmsort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ + return +end subroutine psb_zmsort_u + + +subroutine psb_zmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_zmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_zmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + select case(dir_) + case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,& + & psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ end if - select case(dir_) - case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,& - & psb_asort_up_, psb_asort_down_) + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) ! OK keep going case default - ierr(1) = 3; ierr(2) = dir_; + ierr(1) = 4; ierr(2) = flag_; call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) goto 9999 end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - ierr(1) = 2; ierr(2) = size(ix); - call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) - ! OK keep going - case default - ierr(1) = 4; ierr(2) = flag_; - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) - goto 9999 - end select + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_z_msort') + goto 9999 + endif + + select case(dir_) + case (psb_lsort_up_) + call psi_z_lmsort_up(n,x,iaux,iret) + case (psb_lsort_down_) + call psi_z_lmsort_dw(n,x,iaux,iret) + case (psb_alsort_up_) + call psi_z_almsort_up(n,x,iaux,iret) + case (psb_alsort_down_) + call psi_z_almsort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_z_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_z_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) end if + end if - allocate(iaux(0:n+1),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_z_msort') - goto 9999 - endif + return - select case(dir_) - case (psb_lsort_up_) - call psi_z_lmsort_up(n,x,iaux,iret) - case (psb_lsort_down_) - call psi_z_lmsort_dw(n,x,iaux,iret) - case (psb_alsort_up_) - call psi_z_almsort_up(n,x,iaux,iret) - case (psb_alsort_down_) - call psi_z_almsort_dw(n,x,iaux,iret) - case (psb_asort_up_) - call psi_z_amsort_up(n,x,iaux,iret) - case (psb_asort_down_) - call psi_z_amsort_dw(n,x,iaux,iret) - end select - ! - ! Do the actual reordering, since the inner routines - ! only provide linked pointers. - ! - if (iret == 0 ) then - if (present(ix)) then - call psb_ip_reord(n,x,ix,iaux) - else - call psb_ip_reord(n,x,iaux) - end if - end if +9999 call psb_error_handler(err_act) - return + return -9999 call psb_error_handler(err_act) - return - - - end subroutine psb_zmsort - - subroutine psi_z_lmsort_up(n,k,l,iret) - use psb_const_mod - use psi_lcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p - end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return +end subroutine psb_zmsort + +subroutine psi_z_lmsort_up(n,k,l,iret) + use psb_const_mod + use psi_lcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_z_lmsort_up - - subroutine psi_z_lmsort_dw(n,k,l,iret) - use psb_const_mod - use psi_lcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_z_lmsort_up + +subroutine psi_z_lmsort_dw(n,k,l,iret) + use psb_const_mod + use psi_lcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_z_lmsort_dw - - subroutine psi_z_amsort_up(n,k,l,iret) - use psb_const_mod - use psi_acx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_z_lmsort_dw + +subroutine psi_z_amsort_up(n,k,l,iret) + use psb_const_mod + use psi_acx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_z_amsort_up - - subroutine psi_z_amsort_dw(n,k,l,iret) - use psb_const_mod - use psi_acx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_z_amsort_up + +subroutine psi_z_amsort_dw(n,k,l,iret) + use psb_const_mod + use psi_acx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_z_amsort_dw - - subroutine psi_z_almsort_up(n,k,l,iret) - use psb_const_mod - use psi_alcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) <= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_z_amsort_dw + +subroutine psi_z_almsort_up(n,k,l,iret) + use psb_const_mod + use psi_alcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) > k(q)) then + if (k(p) > k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) <= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) > k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass - - end subroutine psi_z_almsort_up - - subroutine psi_z_almsort_dw(n,k,l,iret) - use psb_const_mod - use psi_alcx_mod - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - ! - integer(psb_ipk_) :: p,q,s,t - ! .. - iret = 0 - ! first step: we are preparing ordered sublists, exploiting - ! what order was already in the input data; negative links - ! mark the end of the sublists - l(0) = 1 - t = n + 1 - do p = 1,n - 1 - if (k(p) >= k(p+1)) then - l(p) = p + 1 - else - l(t) = - (p+1) - t = p + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer end if - end do - l(t) = 0 - l(n) = 0 - ! see if the input was already sorted - if (l(n+1) == 0) then - iret = 1 - return + end do outer + end do mergepass + +end subroutine psi_z_almsort_up + +subroutine psi_z_almsort_dw(n,k,l,iret) + use psb_const_mod + use psi_alcx_mod + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 else - l(n+1) = abs(l(n+1)) + l(t) = - (p+1) + t = p end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass - mergepass: do - ! otherwise, begin a pass through the list. - ! throughout all the subroutine we have: - ! p, q: pointing to the sublists being merged - ! s: pointing to the most recently processed record - ! t: pointing to the end of previously completed sublist - s = 0 - t = n + 1 - p = l(s) - q = l(t) - if (q == 0) exit mergepass - - outer: do + outer: do - if (k(p) < k(q)) then + if (k(p) < k(q)) then - l(s) = sign(q,l(s)) - s = q - q = l(q) - if (q > 0) then - do - if (k(p) >= k(q)) cycle outer - s = q - q = l(q) - if (q <= 0) exit - end do - end if - l(s) = p - s = t + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then do - t = p - p = l(p) - if (p <= 0) exit + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do - else + else - l(s) = sign(p,l(s)) - s = p - p = l(p) - if (p>0) then - do - if (k(p) < k(q)) cycle outer - s = p - p = l(p) - if (p <= 0) exit - end do - end if - ! otherwise, one sublist ended, and we append to it the rest - ! of the other one. - l(s) = q - s = t + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then do - t = q - q = l(q) - if (q <= 0) exit + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit end do end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if - p = -p - q = -q - if (q == 0) then - l(s) = sign(p,l(s)) - l(t) = 0 - exit outer - end if - end do outer - end do mergepass + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass - end subroutine psi_z_almsort_dw +end subroutine psi_z_almsort_dw From 547631a7f4c3e6143e6d9053063dc8ccfa315a74 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 19 Jun 2021 18:19:29 +0200 Subject: [PATCH 10/15] Take out obsolete X_sort_mod --- base/modules/auxil/psb_c_sort_mod.f90 | 610 -------------------------- base/modules/auxil/psb_d_sort_mod.f90 | 572 ------------------------ base/modules/auxil/psb_s_sort_mod.f90 | 572 ------------------------ base/modules/auxil/psb_z_sort_mod.f90 | 610 -------------------------- 4 files changed, 2364 deletions(-) delete mode 100644 base/modules/auxil/psb_c_sort_mod.f90 delete mode 100644 base/modules/auxil/psb_d_sort_mod.f90 delete mode 100644 base/modules/auxil/psb_s_sort_mod.f90 delete mode 100644 base/modules/auxil/psb_z_sort_mod.f90 diff --git a/base/modules/auxil/psb_c_sort_mod.f90 b/base/modules/auxil/psb_c_sort_mod.f90 deleted file mode 100644 index 137c9eb5..00000000 --- a/base/modules/auxil/psb_c_sort_mod.f90 +++ /dev/null @@ -1,610 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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. -! -! -! -! Sorting routines -! References: -! D. Knuth -! The Art of Computer Programming, vol. 3 -! Addison-Wesley -! -! Aho, Hopcroft, Ullman -! Data Structures and Algorithms -! Addison-Wesley -! -module psb_c_sort_mod - use psb_const_mod - - - @INTE@ - - interface psb_msort_unique - subroutine psb_cmsort_u(x,nout,dir) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir - end subroutine psb_cmsort_u - end interface psb_msort_unique - - type psb_c_heap - integer(psb_ipk_) :: last, dir - complex(psb_spk_), allocatable :: keys(:) - contains - procedure, pass(heap) :: init => psb_c_init_heap - procedure, pass(heap) :: howmany => psb_c_howmany - procedure, pass(heap) :: insert => psb_c_insert_heap - procedure, pass(heap) :: get_first => psb_c_heap_get_first - procedure, pass(heap) :: dump => psb_c_dump_heap - procedure, pass(heap) :: free => psb_c_free_heap - end type psb_c_heap - - type psb_c_idx_heap - integer(psb_ipk_) :: last, dir - complex(psb_spk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - contains - procedure, pass(heap) :: init => psb_c_idx_init_heap - procedure, pass(heap) :: howmany => psb_c_idx_howmany - procedure, pass(heap) :: insert => psb_c_idx_insert_heap - procedure, pass(heap) :: get_first => psb_c_idx_heap_get_first - procedure, pass(heap) :: dump => psb_c_idx_dump_heap - procedure, pass(heap) :: free => psb_c_idx_free_heap - end type psb_c_idx_heap - - - interface psb_msort - subroutine psb_cmsort(x,ix,dir,flag) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_cmsort - end interface psb_msort - - interface - subroutine psi_c_lmsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_lmsort_up - subroutine psi_c_lmsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_lmsort_dw - subroutine psi_c_almsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_almsort_up - subroutine psi_c_almsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_almsort_dw - end interface - interface - subroutine psi_c_amsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_amsort_up - subroutine psi_c_amsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_c_amsort_dw - end interface - - - interface psb_qsort - subroutine psb_cqsort(x,ix,dir,flag) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_cqsort - end interface psb_qsort - - interface psb_isort - subroutine psb_cisort(x,ix,dir,flag) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_cisort - end interface psb_isort - - - interface psb_hsort - subroutine psb_chsort(x,ix,dir,flag) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_chsort - end interface psb_hsort - - - interface - subroutine psi_c_insert_heap(key,last,heap,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_spk_), intent(in) :: key - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_c_insert_heap - end interface - - interface - subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_spk_), intent(in) :: key - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: index - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_c_idx_insert_heap - end interface - - - interface - subroutine psi_c_heap_get_first(key,last,heap,dir,info) - import - implicit none - complex(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_c_heap_get_first - end interface - - interface - subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import - complex(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(out) :: index - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_c_idx_heap_get_first - end interface - - interface - subroutine psi_clisrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clisrx_up - subroutine psi_clisrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clisrx_dw - subroutine psi_clisr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clisr_up - subroutine psi_clisr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clisr_dw - subroutine psi_calisrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calisrx_up - subroutine psi_calisrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calisrx_dw - subroutine psi_calisr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calisr_up - subroutine psi_calisr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calisr_dw - subroutine psi_caisrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caisrx_up - subroutine psi_caisrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caisrx_dw - subroutine psi_caisr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caisr_up - subroutine psi_caisr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caisr_dw - end interface - - interface - subroutine psi_clqsrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clqsrx_up - subroutine psi_clqsrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clqsrx_dw - subroutine psi_clqsr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clqsr_up - subroutine psi_clqsr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_clqsr_dw - subroutine psi_calqsrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calqsrx_up - subroutine psi_calqsrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calqsrx_dw - subroutine psi_calqsr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calqsr_up - subroutine psi_calqsr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_calqsr_dw - subroutine psi_caqsrx_up(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caqsrx_up - subroutine psi_caqsrx_dw(n,x,ix) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caqsrx_dw - subroutine psi_caqsr_up(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caqsr_up - subroutine psi_caqsr_dw(n,x) - import - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_caqsr_dw - end interface - -contains - - subroutine psb_c_init_heap(heap,info,dir) - use psb_realloc_mod, only : psb_ensure_size - implicit none - class(psb_c_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - - info = psb_success_ - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_asort_up_ - endif - select case(heap%dir) - case (psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_' - heap%dir = psb_asort_up_ - end select - call psb_ensure_size(psb_heap_resize,heap%keys,info) - - return - end subroutine psb_c_init_heap - - - function psb_c_howmany(heap) result(res) - implicit none - class(psb_c_heap), intent(in) :: heap - integer(psb_ipk_) :: res - res = heap%last - end function psb_c_howmany - - subroutine psb_c_insert_heap(key,heap,info) - use psb_realloc_mod, only : psb_ensure_size - implicit none - - complex(psb_spk_), intent(in) :: key - class(psb_c_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - if (heap%last < 0) then - write(psb_err_unit,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= psb_success_) then - write(psb_err_unit,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_c_insert_heap(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_c_insert_heap - - subroutine psb_c_heap_get_first(key,heap,info) - implicit none - - class(psb_c_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), intent(out) :: key - - - info = psb_success_ - - call psi_c_heap_get_first(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_c_heap_get_first - - subroutine psb_c_dump_heap(iout,heap,info) - - implicit none - class(psb_c_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - - info = psb_success_ - if (iout < 0) then - write(psb_err_unit,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) psb_d_init_heap - procedure, pass(heap) :: howmany => psb_d_howmany - procedure, pass(heap) :: insert => psb_d_insert_heap - procedure, pass(heap) :: get_first => psb_d_heap_get_first - procedure, pass(heap) :: dump => psb_d_dump_heap - procedure, pass(heap) :: free => psb_d_free_heap - end type psb_d_heap - - type psb_d_idx_heap - integer(psb_ipk_) :: last, dir - real(psb_dpk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - contains - procedure, pass(heap) :: init => psb_d_idx_init_heap - procedure, pass(heap) :: howmany => psb_d_idx_howmany - procedure, pass(heap) :: insert => psb_d_idx_insert_heap - procedure, pass(heap) :: get_first => psb_d_idx_heap_get_first - procedure, pass(heap) :: dump => psb_d_idx_dump_heap - procedure, pass(heap) :: free => psb_d_idx_free_heap - end type psb_d_idx_heap - - - interface psb_msort - subroutine psb_dmsort(x,ix,dir,flag) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_dmsort - end interface psb_msort - - - interface psb_bsrch - function psb_dbsrch(key,n,v) result(ipos) - import - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) - end function psb_dbsrch - end interface psb_bsrch - - interface psb_ssrch - function psb_dssrch(key,n,v) result(ipos) - import - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_dpk_) :: key - real(psb_dpk_) :: v(:) - end function psb_dssrch - end interface psb_ssrch - - interface - subroutine psi_d_msort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_d_msort_up - subroutine psi_d_msort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_d_msort_dw - end interface - interface - subroutine psi_d_amsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_d_amsort_up - subroutine psi_d_amsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_d_amsort_dw - end interface - - - interface psb_qsort - subroutine psb_dqsort(x,ix,dir,flag) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_dqsort - end interface psb_qsort - - interface psb_isort - subroutine psb_disort(x,ix,dir,flag) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_disort - end interface psb_isort - - - interface psb_hsort - subroutine psb_dhsort(x,ix,dir,flag) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_dhsort - end interface psb_hsort - - - interface - subroutine psi_d_insert_heap(key,last,heap,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_dpk_), intent(in) :: key - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_d_insert_heap - end interface - - interface - subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_dpk_), intent(in) :: key - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: index - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_d_idx_insert_heap - end interface - - - interface - subroutine psi_d_heap_get_first(key,last,heap,dir,info) - import - implicit none - real(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_d_heap_get_first - end interface - - interface - subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import - real(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(out) :: index - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_d_idx_heap_get_first - end interface - - interface - subroutine psi_disrx_up(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_disrx_up - subroutine psi_disrx_dw(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_disrx_dw - subroutine psi_disr_up(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_disr_up - subroutine psi_disr_dw(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_disr_dw - subroutine psi_daisrx_up(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daisrx_up - subroutine psi_daisrx_dw(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daisrx_dw - subroutine psi_daisr_up(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daisr_up - subroutine psi_daisr_dw(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daisr_dw - end interface - - interface - subroutine psi_dqsrx_up(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_dqsrx_up - subroutine psi_dqsrx_dw(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_dqsrx_dw - subroutine psi_dqsr_up(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_dqsr_up - subroutine psi_dqsr_dw(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_dqsr_dw - subroutine psi_daqsrx_up(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daqsrx_up - subroutine psi_daqsrx_dw(n,x,ix) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daqsrx_dw - subroutine psi_daqsr_up(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daqsr_up - subroutine psi_daqsr_dw(n,x) - import - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_daqsr_dw - end interface - -contains - - subroutine psb_d_init_heap(heap,info,dir) - use psb_realloc_mod, only : psb_ensure_size - implicit none - class(psb_d_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - - info = psb_success_ - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - call psb_ensure_size(psb_heap_resize,heap%keys,info) - - return - end subroutine psb_d_init_heap - - - function psb_d_howmany(heap) result(res) - implicit none - class(psb_d_heap), intent(in) :: heap - integer(psb_ipk_) :: res - res = heap%last - end function psb_d_howmany - - subroutine psb_d_insert_heap(key,heap,info) - use psb_realloc_mod, only : psb_ensure_size - implicit none - - real(psb_dpk_), intent(in) :: key - class(psb_d_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - if (heap%last < 0) then - write(psb_err_unit,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= psb_success_) then - write(psb_err_unit,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_d_insert_heap(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_d_insert_heap - - subroutine psb_d_heap_get_first(key,heap,info) - implicit none - - class(psb_d_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), intent(out) :: key - - - info = psb_success_ - - call psi_d_heap_get_first(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_d_heap_get_first - - subroutine psb_d_dump_heap(iout,heap,info) - - implicit none - class(psb_d_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - - info = psb_success_ - if (iout < 0) then - write(psb_err_unit,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) psb_s_init_heap - procedure, pass(heap) :: howmany => psb_s_howmany - procedure, pass(heap) :: insert => psb_s_insert_heap - procedure, pass(heap) :: get_first => psb_s_heap_get_first - procedure, pass(heap) :: dump => psb_s_dump_heap - procedure, pass(heap) :: free => psb_s_free_heap - end type psb_s_heap - - type psb_s_idx_heap - integer(psb_ipk_) :: last, dir - real(psb_spk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - contains - procedure, pass(heap) :: init => psb_s_idx_init_heap - procedure, pass(heap) :: howmany => psb_s_idx_howmany - procedure, pass(heap) :: insert => psb_s_idx_insert_heap - procedure, pass(heap) :: get_first => psb_s_idx_heap_get_first - procedure, pass(heap) :: dump => psb_s_idx_dump_heap - procedure, pass(heap) :: free => psb_s_idx_free_heap - end type psb_s_idx_heap - - - interface psb_msort - subroutine psb_smsort(x,ix,dir,flag) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_smsort - end interface psb_msort - - - interface psb_bsrch - function psb_sbsrch(key,n,v) result(ipos) - import - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) - end function psb_sbsrch - end interface psb_bsrch - - interface psb_ssrch - function psb_sssrch(key,n,v) result(ipos) - import - implicit none - integer(psb_ipk_) :: ipos, n - real(psb_spk_) :: key - real(psb_spk_) :: v(:) - end function psb_sssrch - end interface psb_ssrch - - interface - subroutine psi_s_msort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_s_msort_up - subroutine psi_s_msort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_s_msort_dw - end interface - interface - subroutine psi_s_amsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_s_amsort_up - subroutine psi_s_amsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - real(psb_spk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_s_amsort_dw - end interface - - - interface psb_qsort - subroutine psb_sqsort(x,ix,dir,flag) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_sqsort - end interface psb_qsort - - interface psb_isort - subroutine psb_sisort(x,ix,dir,flag) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_sisort - end interface psb_isort - - - interface psb_hsort - subroutine psb_shsort(x,ix,dir,flag) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_shsort - end interface psb_hsort - - - interface - subroutine psi_s_insert_heap(key,last,heap,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_spk_), intent(in) :: key - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_s_insert_heap - end interface - - interface - subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_spk_), intent(in) :: key - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: index - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_s_idx_insert_heap - end interface - - - interface - subroutine psi_s_heap_get_first(key,last,heap,dir,info) - import - implicit none - real(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_s_heap_get_first - end interface - - interface - subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import - real(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(out) :: index - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_s_idx_heap_get_first - end interface - - interface - subroutine psi_sisrx_up(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sisrx_up - subroutine psi_sisrx_dw(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sisrx_dw - subroutine psi_sisr_up(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sisr_up - subroutine psi_sisr_dw(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sisr_dw - subroutine psi_saisrx_up(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saisrx_up - subroutine psi_saisrx_dw(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saisrx_dw - subroutine psi_saisr_up(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saisr_up - subroutine psi_saisr_dw(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saisr_dw - end interface - - interface - subroutine psi_sqsrx_up(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sqsrx_up - subroutine psi_sqsrx_dw(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sqsrx_dw - subroutine psi_sqsr_up(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sqsr_up - subroutine psi_sqsr_dw(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_sqsr_dw - subroutine psi_saqsrx_up(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saqsrx_up - subroutine psi_saqsrx_dw(n,x,ix) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saqsrx_dw - subroutine psi_saqsr_up(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saqsr_up - subroutine psi_saqsr_dw(n,x) - import - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_saqsr_dw - end interface - -contains - - subroutine psb_s_init_heap(heap,info,dir) - use psb_realloc_mod, only : psb_ensure_size - implicit none - class(psb_s_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - - info = psb_success_ - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - call psb_ensure_size(psb_heap_resize,heap%keys,info) - - return - end subroutine psb_s_init_heap - - - function psb_s_howmany(heap) result(res) - implicit none - class(psb_s_heap), intent(in) :: heap - integer(psb_ipk_) :: res - res = heap%last - end function psb_s_howmany - - subroutine psb_s_insert_heap(key,heap,info) - use psb_realloc_mod, only : psb_ensure_size - implicit none - - real(psb_spk_), intent(in) :: key - class(psb_s_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - if (heap%last < 0) then - write(psb_err_unit,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= psb_success_) then - write(psb_err_unit,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_s_insert_heap(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_s_insert_heap - - subroutine psb_s_heap_get_first(key,heap,info) - implicit none - - class(psb_s_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), intent(out) :: key - - - info = psb_success_ - - call psi_s_heap_get_first(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_s_heap_get_first - - subroutine psb_s_dump_heap(iout,heap,info) - - implicit none - class(psb_s_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - - info = psb_success_ - if (iout < 0) then - write(psb_err_unit,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) psb_z_init_heap - procedure, pass(heap) :: howmany => psb_z_howmany - procedure, pass(heap) :: insert => psb_z_insert_heap - procedure, pass(heap) :: get_first => psb_z_heap_get_first - procedure, pass(heap) :: dump => psb_z_dump_heap - procedure, pass(heap) :: free => psb_z_free_heap - end type psb_z_heap - - type psb_z_idx_heap - integer(psb_ipk_) :: last, dir - complex(psb_dpk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - contains - procedure, pass(heap) :: init => psb_z_idx_init_heap - procedure, pass(heap) :: howmany => psb_z_idx_howmany - procedure, pass(heap) :: insert => psb_z_idx_insert_heap - procedure, pass(heap) :: get_first => psb_z_idx_heap_get_first - procedure, pass(heap) :: dump => psb_z_idx_dump_heap - procedure, pass(heap) :: free => psb_z_idx_free_heap - end type psb_z_idx_heap - - - interface psb_msort - subroutine psb_zmsort(x,ix,dir,flag) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_zmsort - end interface psb_msort - - interface - subroutine psi_z_lmsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_lmsort_up - subroutine psi_z_lmsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_lmsort_dw - subroutine psi_z_almsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_almsort_up - subroutine psi_z_almsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_almsort_dw - end interface - interface - subroutine psi_z_amsort_up(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_amsort_up - subroutine psi_z_amsort_dw(n,k,l,iret) - import - implicit none - integer(psb_ipk_) :: n, iret - complex(psb_dpk_) :: k(n) - integer(psb_ipk_) :: l(0:n+1) - end subroutine psi_z_amsort_dw - end interface - - - interface psb_qsort - subroutine psb_zqsort(x,ix,dir,flag) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_zqsort - end interface psb_qsort - - interface psb_isort - subroutine psb_zisort(x,ix,dir,flag) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_zisort - end interface psb_isort - - - interface psb_hsort - subroutine psb_zhsort(x,ix,dir,flag) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine psb_zhsort - end interface psb_hsort - - - interface - subroutine psi_z_insert_heap(key,last,heap,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_dpk_), intent(in) :: key - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_z_insert_heap - end interface - - interface - subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info) - import - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_dpk_), intent(in) :: key - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: index - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_z_idx_insert_heap - end interface - - - interface - subroutine psi_z_heap_get_first(key,last,heap,dir,info) - import - implicit none - complex(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_z_heap_get_first - end interface - - interface - subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import - complex(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(out) :: index - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_z_idx_heap_get_first - end interface - - interface - subroutine psi_zlisrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlisrx_up - subroutine psi_zlisrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlisrx_dw - subroutine psi_zlisr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlisr_up - subroutine psi_zlisr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlisr_dw - subroutine psi_zalisrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalisrx_up - subroutine psi_zalisrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalisrx_dw - subroutine psi_zalisr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalisr_up - subroutine psi_zalisr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalisr_dw - subroutine psi_zaisrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaisrx_up - subroutine psi_zaisrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaisrx_dw - subroutine psi_zaisr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaisr_up - subroutine psi_zaisr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaisr_dw - end interface - - interface - subroutine psi_zlqsrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlqsrx_up - subroutine psi_zlqsrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlqsrx_dw - subroutine psi_zlqsr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlqsr_up - subroutine psi_zlqsr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zlqsr_dw - subroutine psi_zalqsrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalqsrx_up - subroutine psi_zalqsrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalqsrx_dw - subroutine psi_zalqsr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalqsr_up - subroutine psi_zalqsr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zalqsr_dw - subroutine psi_zaqsrx_up(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaqsrx_up - subroutine psi_zaqsrx_dw(n,x,ix) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(inout) :: ix(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaqsrx_dw - subroutine psi_zaqsr_up(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaqsr_up - subroutine psi_zaqsr_dw(n,x) - import - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: n - end subroutine psi_zaqsr_dw - end interface - -contains - - subroutine psb_z_init_heap(heap,info,dir) - use psb_realloc_mod, only : psb_ensure_size - implicit none - class(psb_z_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - - info = psb_success_ - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_asort_up_ - endif - select case(heap%dir) - case (psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_' - heap%dir = psb_asort_up_ - end select - call psb_ensure_size(psb_heap_resize,heap%keys,info) - - return - end subroutine psb_z_init_heap - - - function psb_z_howmany(heap) result(res) - implicit none - class(psb_z_heap), intent(in) :: heap - integer(psb_ipk_) :: res - res = heap%last - end function psb_z_howmany - - subroutine psb_z_insert_heap(key,heap,info) - use psb_realloc_mod, only : psb_ensure_size - implicit none - - complex(psb_dpk_), intent(in) :: key - class(psb_z_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - if (heap%last < 0) then - write(psb_err_unit,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= psb_success_) then - write(psb_err_unit,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_z_insert_heap(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_z_insert_heap - - subroutine psb_z_heap_get_first(key,heap,info) - implicit none - - class(psb_z_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), intent(out) :: key - - - info = psb_success_ - - call psi_z_heap_get_first(key,& - & heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_z_heap_get_first - - subroutine psb_z_dump_heap(iout,heap,info) - - implicit none - class(psb_z_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - - info = psb_success_ - if (iout < 0) then - write(psb_err_unit,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) Date: Wed, 30 Jun 2021 17:44:11 +0200 Subject: [PATCH 11/15] Update link to AMG --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 07eb378e..a86db934 100644 --- a/README.md +++ b/README.md @@ -133,8 +133,8 @@ Dario Pascucci RELATED SOFTWARE ---------------- If you are looking for more sophisticated preconditioners, you may be -interested in the package MLD2P4 from - +interested in the package AMG4PSBLAS from + Contact: From c38660c76c0bf1271efe9cb4d1830bf77dd286be Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Tue, 6 Jul 2021 16:54:05 +0200 Subject: [PATCH 12/15] Added function psb_c_g2l --- cbind/base/psb_c_base.h | 2 ++ cbind/base/psb_c_serial_cbind_mod.F90 | 33 +++++++++++++++++++++++++++ 2 files changed, 35 insertions(+) diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index e054daf6..0e5a09f9 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -102,6 +102,8 @@ extern "C" { psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd); psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); psb_i_t psb_c_cd_get_global_indices(psb_l_t idx[], psb_i_t nidx, bool owned, psb_c_descriptor *cd); + psb_i_t psb_c_g2l(psb_c_descriptor *cdh,psb_l_t gindex,bool cowned); + /* legal values for upd argument */ #define psb_upd_srch_ 98764 diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index b298d84a..dba41b67 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -204,5 +204,38 @@ contains end function psb_c_cvect_set_vect + function psb_c_g2l(cdh,gindex,cowned) bind(c) result(lindex) + use psb_base_mod + implicit none + + integer(psb_c_lpk_), value :: gindex + logical(c_bool), value :: cowned + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_) :: lindex + + type(psb_desc_type), pointer :: descp + integer(psb_ipk_) :: info, localindex, ixb, iam, np + logical :: owned + + ixb = psb_c_get_index_base() + owned = cowned + lindex = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + + call psb_info(descp%get_context(),iam,np) + if (ixb == 1) then + call descp%indxmap%g2l(gindex,localindex,info,owned=owned) + lindex = localindex + else + call descp%indxmap%g2l(gindex+(1-ixb),localindex,info,owned=owned) + lindex = localindex-(1-ixb) + endif + + end function psb_c_g2l + end module psb_c_serial_cbind_mod From c1727fec5d312d96d4e903cec57ea37fbd89ad90 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Wed, 15 Sep 2021 11:05:59 +0200 Subject: [PATCH 13/15] Implemented C/C++ fix for complex.h --- cbind/base/psb_c_base.h | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index 0e5a09f9..82c4cda9 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -32,8 +32,15 @@ extern "C" { typedef float psb_s_t; typedef double psb_d_t; - typedef float complex psb_c_t; - typedef double complex psb_z_t; + +#ifdef __cplusplus + using psb_c_t = std::complex; + using psb_z_t = std::complex; +#else + typedef float complex psb_c_t; + typedef float complex psb_z_t; +#endif + #define PSB_ERR_ERROR -1 #define PSB_ERR_SUCCESS 0 From 874dd7825e40ac8ca2ee67091d8a9447868a3ef5 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 16 Sep 2021 08:57:41 +0200 Subject: [PATCH 14/15] Fix for C++ typedef vs using --- cbind/base/psb_c_base.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index 82c4cda9..febb2ad3 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -34,8 +34,8 @@ extern "C" { typedef double psb_d_t; #ifdef __cplusplus - using psb_c_t = std::complex; - using psb_z_t = std::complex; + typedef std::complex psb_c_t; + typedef std::complex psb_z_t; #else typedef float complex psb_c_t; typedef float complex psb_z_t; From adbae358e4f9edcda1fcadd5f1cf33ed32bcec9f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 24 Sep 2021 11:42:51 +0200 Subject: [PATCH 15/15] Improve cleanup on psb_close --- base/modules/penv/psi_penv_mod.F90 | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/base/modules/penv/psi_penv_mod.F90 b/base/modules/penv/psi_penv_mod.F90 index b10b6a03..6a5dd7aa 100644 --- a/base/modules/penv/psi_penv_mod.F90 +++ b/base/modules/penv/psi_penv_mod.F90 @@ -982,9 +982,26 @@ contains !if ((ctxt /= mpi_comm_null).and.(ctxt /= mpi_comm_world)) then if (allocated(ctxt%ctxt)) then !write(0,*) ctxt%ctxt,mpi_comm_world,mpi_comm_null - if ((ctxt%ctxt /= mpi_comm_world).and.(ctxt%ctxt /= mpi_comm_null)) call mpi_comm_Free(ctxt%ctxt,info) + if ((ctxt%ctxt /= mpi_comm_world).and.(ctxt%ctxt /= mpi_comm_null)) & + & call mpi_comm_Free(ctxt%ctxt,info) end if - + if (close_) then + if (info == 0) call mpi_op_free(mpi_mamx_op,info) + if (info == 0) call mpi_op_free(mpi_mamn_op,info) + if (info == 0) call mpi_op_free(mpi_eamx_op,info) + if (info == 0) call mpi_op_free(mpi_eamn_op,info) + if (info == 0) call mpi_op_free(mpi_samx_op,info) + if (info == 0) call mpi_op_free(mpi_samn_op,info) + if (info == 0) call mpi_op_free(mpi_damx_op,info) + if (info == 0) call mpi_op_free(mpi_damn_op,info) + if (info == 0) call mpi_op_free(mpi_camx_op,info) + if (info == 0) call mpi_op_free(mpi_camn_op,info) + if (info == 0) call mpi_op_free(mpi_zamx_op,info) + if (info == 0) call mpi_op_free(mpi_zamn_op,info) + if (info == 0) call mpi_op_free(mpi_snrm2_op,info) + if (info == 0) call mpi_op_free(mpi_dnrm2_op,info) + end if + if (close_) call mpi_finalize(info) #endif