diff --git a/test/cdasb/Makefile b/test/cdasb/Makefile deleted file mode 100644 index a4a677f5..00000000 --- a/test/cdasb/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -INSTALLDIR=../.. -INCDIR=$(INSTALLDIR)/include -MODDIR=$(INSTALLDIR)/modules/ -include $(INCDIR)/Make.inc.psblas -# -# Libraries used -LIBDIR=$(INSTALLDIR)/lib -PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base -LDLIBS=$(PSBLDLIBS) -# -# Compilers and such -# -CCOPT= -g -FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). - - -EXEDIR=./runs - -all: exed psb_d_pde3d - -exed: - (if test ! -d $(EXEDIR) ; then mkdir $(EXEDIR); fi) - -psb_d_pde3d: psb_d_pde3d.o - $(FLINK) psb_d_pde3d.o -o psb_d_pde3d $(PSBLAS_LIB) $(LDLIBS) - /bin/mv psb_d_pde3d $(EXEDIR) - - - -clean: - /bin/rm -f psb_d_pde3d.o *$(.mod) $(EXEDIR)/psb_d_pde3d -verycleanlib: - (cd ../..; make veryclean) -lib: - (cd ../../; make library) - - - diff --git a/test/cdasb/psb_d_pde3d.f90 b/test/cdasb/psb_d_pde3d.f90 deleted file mode 100644 index 974298f0..00000000 --- a/test/cdasb/psb_d_pde3d.f90 +++ /dev/null @@ -1,860 +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. -! -! -! File: psb_d_pde3d.f90 -! -! Program: psb_d_pde3d -! This sample program solves a linear system obtained by discretizing a -! PDE with Dirichlet BCs. -! -! -! The PDE is a general second order equation in 3d -! -! 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. -! -! There are three choices available for data distribution: -! 1. A simple BLOCK distribution -! 2. A ditribution based on arbitrary assignment of indices to processes, -! typically from a graph partitioner -! 3. A 3D distribution in which the unit cube is partitioned -! into subcubes, each one assigned to a process. -! -! -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_mpk_) :: npx,npy,npz, iamx,iamy,iamz - integer(psb_ipk_) :: 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) - call psb_cd_set_large_threshold(1000) - call psb_cd_set_maxspace(10000) - - 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) - - - block - ! - ! Test adjcncy methods - ! - integer(psb_mpk_), allocatable :: neighbours(:) - integer(psb_mpk_) :: cnt - logical, parameter :: debug_adj=.false. - if (debug_adj.and.(np > 1)) then - cnt = 0 - allocate(neighbours(np)) - if (iamx < npx-1) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0) - end if - if (iamy < npy-1) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0) - end if - if (iamz < npz-1) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0) - end if - if (iamx >0) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0) - end if - if (iamy >0) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0) - end if - if (iamz >0) then - cnt = cnt + 1 - call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0) - end if - call psb_realloc(cnt, neighbours,info) - call desc_a%set_p_adjcncy(neighbours) - write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy() - end if - end block - - - 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 psb_d_pde3d - use psb_base_mod - use psb_prec_mod - use psb_krylov_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 - integer(psb_epk_) :: system_size - - ! miscellaneous - real(psb_dpk_), parameter :: one = done - real(psb_dpk_) :: t1, t2, tprec - - ! sparse matrix and preconditioner - type(psb_dspmat_type) :: a, aremap - type(psb_dprec_type) :: prec - ! descriptor - type(psb_desc_type) :: desc_a, desc_rmp, desc_blk - ! dense vectors - type(psb_d_vect_type) :: xxv,bv - ! parallel environment - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np - - ! solver parameters - integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart, idest - integer(psb_epk_) :: amatsize, precsize, descsize, d2size - real(psb_dpk_) :: err, eps - integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:) - ! other variables - integer(psb_ipk_) :: info, i, rnp - 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_errstatus_fatal()) goto 9999 - name='pde3d90' - 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,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - - ! - ! 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,xxv,desc_a,afmt,info,partition=ipart) - 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 psb_cd_renum_block(desc_a,desc_blk,info) - do rnp = 2, np/2+1 - if (iam == 0) write(0,*) 'Remapping from ',np,' to ',rnp - flush(0) - call psb_barrier(ctxt) - call psb_remap(rnp,desc_blk,a,desc_rmp,idest,isrc,nrsrc,aremap,info) - flush(0) - call psb_barrier(ctxt) - if (iam == 0) write(0,*) ' Info ',info - end do - ! - ! cleanup storage and exit - ! - call psb_gefree(bv,desc_a,info) - call psb_gefree(xxv,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,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - type(psb_ctxt_type) :: ctxt - character(len=*) :: kmethd, ptype, afmt - integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart - integer(psb_ipk_) :: np, iam - integer(psb_ipk_) :: ip, inp_unit - character(len=1024) :: filename - - call psb_info(ctxt, iam, np) - - if (iam == 0) then - if (command_argument_count()>0) then - call get_command_argument(1,filename) - inp_unit = 30 - open(inp_unit,file=filename,action='read',iostat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ctxt) - stop - else - write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' - end if - else - inp_unit=psb_inp_unit - end if - read(inp_unit,*) ip - if (ip >= 3) then - read(inp_unit,*) kmethd - read(inp_unit,*) ptype - read(inp_unit,*) afmt - - read(inp_unit,*) idim - if (ip >= 4) then - read(inp_unit,*) ipart - else - ipart = 3 - endif - if (ip >= 5) then - read(inp_unit,*) istopc - else - istopc=1 - endif - if (ip >= 6) then - read(inp_unit,*) itmax - else - itmax=500 - endif - if (ip >= 7) then - read(inp_unit,*) itrace - else - itrace=-1 - endif - if (ip >= 8) then - read(inp_unit,*) irst - else - irst=1 - endif - - write(psb_out_unit,'("Solving 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 - select case(ipart) - case(1) - write(psb_out_unit,'("Data distribution : BLOCK")') - case(3) - write(psb_out_unit,'("Data distribution : 3D")') - case default - ipart = 3 - write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') - end select - write(psb_out_unit,'("Preconditioner : ",a)') ptype - write(psb_out_unit,'("Iterative method : ",a)') kmethd - write(psb_out_unit,'(" ")') - else - ! wrong number of parameter, print an error message and exit - call pr_usage(izero) - call psb_abort(ctxt) - stop 1 - endif - if (inp_unit /= psb_inp_unit) then - close(inp_unit) - end if - - end if - ! broadcast parameters to all processors - call psb_bcast(ctxt,kmethd) - call psb_bcast(ctxt,afmt) - call psb_bcast(ctxt,ptype) - call psb_bcast(ctxt,idim) - call psb_bcast(ctxt,ipart) - call psb_bcast(ctxt,istopc) - call psb_bcast(ctxt,itmax) - call psb_bcast(ctxt,itrace) - call psb_bcast(ctxt,irst) - - 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: pde3d90 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,*)' ipart data partition 1 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 psb_d_pde3d - - diff --git a/test/cdasb/runs/tcd.inp b/test/cdasb/runs/tcd.inp deleted file mode 100644 index ae5c50cf..00000000 --- a/test/cdasb/runs/tcd.inp +++ /dev/null @@ -1,12 +0,0 @@ -8 Number of entries below this -BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR -BJAC Preconditioner NONE DIAG BJAC -CSR Storage format for matrix A: CSR COO -100 Domain size (acutal system is this**3 (pde3d) or **2 (pde2d) ) -3 Partition: 1 BLOCK 3 3D -2 Stopping criterion 1 2 -0100 MAXIT --1 ITRACE -002 IRST restart for RGMRES and BiCGSTABL - - diff --git a/test/idx/Makefile b/test/idx/Makefile deleted file mode 100644 index 7e8a9fcc..00000000 --- a/test/idx/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -INSTALLDIR=../.. -INCDIR=$(INSTALLDIR)/include -MODDIR=$(INSTALLDIR)/modules/ -include $(INCDIR)/Make.inc.psblas -# -# Libraries used -LIBDIR=$(INSTALLDIR)/lib -PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base -LDLIBS=$(PSBLDLIBS) -# -# Compilers and such -# -CCOPT= -g -FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). - - -EXEDIR=./ - -all: tryidxijk - -tryidxijk: tryidxijk.o - $(FLINK) tryidxijk.o -o tryidxijk $(PSBLAS_LIB) $(LDLIBS) - /bin/mv tryidxijk $(EXEDIR) - -clean: - /bin/rm -f tryidxijk.o *$(.mod) \ - $(EXEDIR)/tryidxijk $(EXEDIR)/psb_d_pde3d -verycleanlib: - (cd ../..; make veryclean) -lib: - (cd ../../; make library) - - - diff --git a/test/idx/tryidxijk.f90 b/test/idx/tryidxijk.f90 deleted file mode 100644 index 31a71ad3..00000000 --- a/test/idx/tryidxijk.f90 +++ /dev/null @@ -1,20 +0,0 @@ -program tryidxijk - use psb_base_mod - use psb_util_mod - - integer(psb_lpk_) :: idx,idxm - integer(psb_ipk_) :: nx,ny,nz - integer(psb_ipk_) :: i,j,k, sidx - - idxm = 1000 - idxm = idxm*2000*1000 - nx = 2000 - ny = 2000 - nz = 2000 - do idx = idxm+300*1000*1000, idxm+300*1000*1000+50000 - call idx2ijk(i,j,k,idx,nx,ny,nz) - sidx = idx - write(*,*) 'idx2ijk: ',idx,i,j,k, sidx - end do - -end program tryidxijk diff --git a/test/kernel/Makefile b/test/kernel/Makefile deleted file mode 100644 index 9dc88e59..00000000 --- a/test/kernel/Makefile +++ /dev/null @@ -1,49 +0,0 @@ -# -# 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 deleted file mode 100644 index 40a79982..00000000 --- a/test/kernel/d_file_spmv.f90 +++ /dev/null @@ -1,297 +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. -! -! -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 deleted file mode 100644 index e96736a8..00000000 --- a/test/kernel/pdgenspmv.f90 +++ /dev/null @@ -1,770 +0,0 @@ -! -! 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 deleted file mode 100644 index bd98c266..00000000 --- a/test/kernel/runs/fspmv.inp +++ /dev/null @@ -1,5 +0,0 @@ -pde100.mtx -MM -0 - - diff --git a/test/kernel/runs/spmv.inp b/test/kernel/runs/spmv.inp deleted file mode 100644 index 91844ce2..00000000 --- a/test/kernel/runs/spmv.inp +++ /dev/null @@ -1,3 +0,0 @@ -CSR -50 - diff --git a/test/kernel/s_file_spmv.f90 b/test/kernel/s_file_spmv.f90 deleted file mode 100644 index ebbb85cd..00000000 --- a/test/kernel/s_file_spmv.f90 +++ /dev/null @@ -1,295 +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. -! -! -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 deleted file mode 100644 index 3860a3c3..00000000 --- a/test/kernel/vecoperation.f90 +++ /dev/null @@ -1,385 +0,0 @@ -! -! 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 deleted file mode 100644 index 8a98657e..00000000 --- a/test/torture/Makefile +++ /dev/null @@ -1,45 +0,0 @@ -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 deleted file mode 100644 index ed6a9423..00000000 --- a/test/torture/psb_c_mvsv_tester.f90 +++ /dev/null @@ -1,2811 +0,0 @@ -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 deleted file mode 100644 index baabf216..00000000 --- a/test/torture/psb_d_mvsv_tester.f90 +++ /dev/null @@ -1,2812 +0,0 @@ -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 deleted file mode 100644 index f997bf01..00000000 --- a/test/torture/psb_mvsv_tester.f90 +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 34c1e9eb..00000000 --- a/test/torture/psb_s_mvsv_tester.f90 +++ /dev/null @@ -1,2809 +0,0 @@ -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 deleted file mode 100644 index bc84a447..00000000 --- a/test/torture/psb_z_mvsv_tester.f90 +++ /dev/null @@ -1,2810 +0,0 @@ -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 deleted file mode 100644 index 35851ada..00000000 --- a/test/torture/psbtf.f90 +++ /dev/null @@ -1,754 +0,0 @@ -! -! 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 - - -