diff --git a/src/modules/psb_serial_mod.f90 b/src/modules/psb_serial_mod.f90 index 7be62e42..c38eb5e5 100644 --- a/src/modules/psb_serial_mod.f90 +++ b/src/modules/psb_serial_mod.f90 @@ -265,8 +265,8 @@ module psb_serial_mod end subroutine psb_zspinfo end interface - interface psb_spgtrow - subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw) + interface psb_spgtblk + subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -275,8 +275,8 @@ module psb_serial_mod integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_dspgtrow - subroutine psb_zspgtrow(irw,a,b,info,append,iren,lrw) + end subroutine psb_dspgtblk + subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -285,11 +285,11 @@ module psb_serial_mod integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_zspgtrow + end subroutine psb_zspgtblk end interface - interface psb_sp_extrow - subroutine psb_dspextrow(irw,a,nz,ia,ja,val,info,iren,lrw) + interface psb_sp_getrow + subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -299,8 +299,8 @@ module psb_serial_mod integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_dspextrow - subroutine psb_zspextrow(irw,a,nz,ia,ja,val,info,iren,lrw) + end subroutine psb_dspgetrow + subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -310,7 +310,7 @@ module psb_serial_mod integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_zspextrow + end subroutine psb_zspgetrow end interface interface psb_neigh diff --git a/src/prec/psb_dbldaggrmat.f90 b/src/prec/psb_dbldaggrmat.f90 index 8b9191f4..0f750f5a 100644 --- a/src/prec/psb_dbldaggrmat.f90 +++ b/src/prec/psb_dbldaggrmat.f90 @@ -199,9 +199,9 @@ contains jl = 0 do i=1,a%m,50 nlr = min(a%m-i+1,50) - call psb_spgtrow(i,a,b,info,append=.true.,iren=p%mlia,lrw=i+nlr-1) + call psb_spgtblk(i,a,b,info,append=.true.,iren=p%mlia,lrw=i+nlr-1) if(info /= 0) then - call psb_errpush(4010,name,a_err='spgtrow') + call psb_errpush(4010,name,a_err='spgtblk') goto 9999 end if diff --git a/src/prec/psb_dilu_fct.f90 b/src/prec/psb_dilu_fct.f90 index 2dc991f0..d521e144 100644 --- a/src/prec/psb_dilu_fct.f90 +++ b/src/prec/psb_dilu_fct.f90 @@ -177,7 +177,7 @@ contains ! ! Here we take a fast shortcut if possible, otherwise - ! use spgtrow, slower but able (in principle) to handle + ! use spgtblk, slower but able (in principle) to handle ! anything. ! if (a%fida=='CSR') then @@ -201,10 +201,10 @@ contains if ((mod(i,nrb) == 1).or.(nrb==1)) then irb = min(ma-i+1,nrb) - call psb_spgtrow(i,a,trw,info,lrw=i+irb-1) + call psb_spgtblk(i,a,trw,info,lrw=i+irb-1) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -343,10 +343,10 @@ contains if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then irb = min(m-i+1,nrb) - call psb_spgtrow(i-ma,b,trw,info,lrw=i-ma+irb-1) + call psb_spgtblk(i-ma,b,trw,info,lrw=i-ma+irb-1) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/prec/psb_zbldaggrmat.f90 b/src/prec/psb_zbldaggrmat.f90 index bb26e2aa..8210b416 100644 --- a/src/prec/psb_zbldaggrmat.f90 +++ b/src/prec/psb_zbldaggrmat.f90 @@ -199,9 +199,9 @@ contains jl = 0 do i=1,a%m,50 nlr = min(a%m-i+1,50) - call psb_spgtrow(i,a,b,info,append=.true.,iren=p%mlia,lrw=i+nlr-1) + call psb_spgtblk(i,a,b,info,append=.true.,iren=p%mlia,lrw=i+nlr-1) if(info /= 0) then - call psb_errpush(4010,name,a_err='spgtrow') + call psb_errpush(4010,name,a_err='spgtblk') goto 9999 end if diff --git a/src/prec/psb_zilu_fct.f90 b/src/prec/psb_zilu_fct.f90 index b63e9452..a15e292d 100644 --- a/src/prec/psb_zilu_fct.f90 +++ b/src/prec/psb_zilu_fct.f90 @@ -175,7 +175,7 @@ contains ! ! Here we take a fast shortcut if possible, otherwise - ! use spgtrow, slower but able (in principle) to handle + ! use spgtblk, slower but able (in principle) to handle ! anything. ! if (a%fida=='CSR') then @@ -199,10 +199,10 @@ contains if ((mod(i,nrb) == 1).or.(nrb==1)) then irb = min(ma-i+1,nrb) - call psb_spgtrow(i,a,trw,info,lrw=i+irb-1) + call psb_spgtblk(i,a,trw,info,lrw=i+irb-1) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -341,10 +341,10 @@ contains if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then irb = min(m-i+1,nrb) - call psb_spgtrow(i-ma,b,trw,info,lrw=i-ma+irb-1) + call psb_spgtblk(i-ma,b,trw,info,lrw=i-ma+irb-1) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/prec/psb_zumf_bld.f90 b/src/prec/psb_zumf_bld.f90 index dcc19a95..9251078f 100644 --- a/src/prec/psb_zumf_bld.f90 +++ b/src/prec/psb_zumf_bld.f90 @@ -52,6 +52,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info) character(len=5) :: fmt character :: upd='F' integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act + integer :: i_err(5) logical, parameter :: debug=.false. character(len=20) :: name, ch_err diff --git a/src/serial/Makefile b/src/serial/Makefile index 888fd428..b4f178ae 100644 --- a/src/serial/Makefile +++ b/src/serial/Makefile @@ -4,10 +4,10 @@ include ../../Make.inc FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \ psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \ psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \ - psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtrow.o \ + psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtblk.o \ psb_dspinfo.o psb_dspscal.o psb_dsymbmm.o psb_dtransp.o \ - psb_dipcoo2csc.o psb_dspextrow.o lsame.o psb_zspextrow.o\ - psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtrow.o\ + psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\ + psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtblk.o\ psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\ psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \ psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\ diff --git a/src/serial/psb_drwextd.f90 b/src/serial/psb_drwextd.f90 index 2ee1cb37..a39793f6 100644 --- a/src/serial/psb_drwextd.f90 +++ b/src/serial/psb_drwextd.f90 @@ -58,7 +58,7 @@ subroutine psb_drwextd(nr,a,info,b) call psb_realloc(size(a%ia1)+jb,a%ia1,info) call psb_realloc(size(a%aspk)+jb,a%aspk,info) do i=1, min(nr-a%m,b%m) - ! Should use spgtrow. + ! Should use spgtblk. ! Don't care for the time being. a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i) ja = a%ia2(a%m+i) diff --git a/src/serial/psb_dspextrow.f90 b/src/serial/psb_dspextrow.f90 deleted file mode 100644 index 95fbbdfa..00000000 --- a/src/serial/psb_dspextrow.f90 +++ /dev/null @@ -1,162 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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_dspextrow.f90 -! Subroutine: psb_dspextrow -! Gets one or more rows from a sparse matrix. -! Parameters: - -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into NZ,IA,JA,VAL in COO * -!* format. * -!* * -!***************************************************************************** -subroutine psb_dspextrow(irw,a,nz,ia,ja,val,info,iren,lrw) - use psb_spmat_type - use psb_string_mod - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, intent(inout) :: ia(:), ja(:) - real(kind(1.d0)), intent(inout) :: val(:) - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - interface psb_spgtrow - subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_dspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - end subroutine psb_dspgtrow - end interface - - integer :: lrw_, ierr(2), err_act - type(psb_dspmat_type) :: b - integer, pointer :: iren_(:) - character(len=20) :: name, ch_err - - - name='psb_sp_extrow' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPEXTROW input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b,info) - - if (present(iren)) then - call psb_spgtrow(irw,a,b,info,iren=iren,lrw=lrw_) - else - call psb_spgtrow(irw,a,b,info,lrw=lrw_) - end if - if (info /= 0) then - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (toupper(b%fida) /= 'COO') then - info=4010 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - nz = b%infoa(psb_nnz_) - - if (size(ia)>= nz) then - ia(1:nz) = b%ia1(1:nz) - else - info = 135 - ierr(1) = 4 - ierr(2) = size(ia) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - if (size(ja)>= nz) then - ja(1:nz) = b%ia2(1:nz) - else - info = 135 - ierr(1) = 5 - ierr(2) = size(ja) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - if (size(val)>= nz) then - val(1:nz) = b%aspk(1:nz) - else - info = 135 - ierr(1) = 6 - ierr(2) = size(val) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - - call psb_sp_free(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return - end if - return - - -end subroutine psb_dspextrow - diff --git a/src/serial/psb_dspgtdiag.f90 b/src/serial/psb_dspgtdiag.f90 index 008e422b..3e0e354d 100644 --- a/src/serial/psb_dspgtdiag.f90 +++ b/src/serial/psb_dspgtdiag.f90 @@ -51,8 +51,8 @@ subroutine psb_dspgtdiag(a,d,info) real(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info - interface psb_spgtrow - subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw) + interface psb_spgtblk + subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -61,7 +61,7 @@ subroutine psb_dspgtdiag(a,d,info) integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_dspgtrow + end subroutine psb_dspgtblk end interface type(psb_dspmat_type) :: tmpa @@ -102,10 +102,10 @@ subroutine psb_dspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_spgtrow(i,a,tmpa,info,lrw=irb) + call psb_spgtblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/serial/psb_dspgtrow.f90 b/src/serial/psb_dspgtrow.f90 deleted file mode 100644 index 694d7f97..00000000 --- a/src/serial/psb_dspgtrow.f90 +++ /dev/null @@ -1,515 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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_dspgtrow.f90 -! Subroutine: psb_dspgtrow -! Gets one or more rows from a sparse matrix. -! Parameters: - -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, once * -!* we get to actually write the code..... * -!* * -!***************************************************************************** -subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_dspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - - logical :: append_ - integer, pointer :: iren_(:) - integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgtrow' - info = 0 - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTROW input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - if (present(iren)) then - iren_=>iren - else - iren_ => null() - end if - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - endif - - if (a%fida == 'CSR') then - call csr_dspgtrow(irw_,a,b,append_,iren_,lrw_) - - else if (a%fida == 'COO') then - call coo_dspgtrow(irw_,a,b,append_,iren_,lrw_) - - else if (a%fida == 'JAD') then - call jad_dspgtrow(irw_,a,b,append_,iren_,lrw_) - - else - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return - end if - return - -contains - - subroutine csr_dspgtrow(irw,a,b,append,iren,lrw) - - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer :: irw - type(psb_dspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - integer :: idx,i,j ,nr,nz,nzb, row_idx - integer, pointer :: indices(:) - - if (append) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr)) - do i=1,nr - indices(i)=a%pl(irw+i-1) - nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) - end do - - if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - k=0 - if(associated(iren)) then - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(row_idx) - b%ia2(nzb+k) = iren(a%ia1(j)) - end do - end do - else - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = row_idx - b%ia2(nzb+k) = a%ia1(j) - end do - end do - end if - - b%infoa(psb_nnz_) = nzb+k - b%m = b%m+nr - b%k = max(b%k,a%k) - - else - idx = irw - - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - nr = lrw - irw + 1 - nz = a%ia2(idx+nr) - a%ia2(idx) - - if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - b%fida='COO' - - if (associated(iren)) then - k=0 - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(i) - b%ia2(nzb+k) = iren(a%ia1(j)) - end do - enddo - else - k=0 - - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - b%ia1(nzb+k) = i - b%ia2(nzb+k) = a%ia1(j) - b%aspk(nzb+k) = a%aspk(j) -!!$ write(0,*) 'csr_gtrow: in:',a%aspk(j),i,a%ia1(j) - end do - enddo - end if - b%infoa(psb_nnz_) = nzb+nz - if (a%pr(1) /= 0) then - write(0,*) 'Feeling lazy today, Right Permutation will have to wait' - endif - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - - endif - - end subroutine csr_dspgtrow - - subroutine coo_dspgtrow(irw,a,b,append,iren,lrw) - - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer :: irw - type(psb_dspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - nza = a%infoa(psb_nnz_) - if (a%pl(1) /= 0) then - write(0,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' - idx = -1 - else - idx = irw - endif - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - - if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then - ! In this case we can do a binary search. - do - call ibsrch(ip,irw,nza,a%ia1) - if (ip /= -1) exit - irw = irw + 1 - if (irw > lrw) then - write(0,*) 'Warning : did not find any rows. Is this an error? ',irw,lrw,idx - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia1(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - call ibsrch(jp,lrw,nza,a%ia1) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(0,*) 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia1(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nz = jp - ip +1 - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - b%fida='COO' - if (associated(iren)) then - do i=ip,jp - nzb = nzb + 1 - b%aspk(nzb) = a%aspk(i) - b%ia1(nzb) = iren(a%ia1(i)) - b%ia2(nzb) = iren(a%ia2(i)) - enddo - else - do i=ip,jp - nzb = nzb + 1 - b%aspk(nzb) = a%aspk(i) - b%ia1(nzb) = a%ia1(i) - b%ia2(nzb) = a%ia2(i) - enddo - end if - end if - - else - - nz = (nza*(lrw-irw+1))/max(a%m,1) - - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - if (associated(iren)) then - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nz) then - nz = k - call psb_sp_reall(b,nzb+nz,iret) - end if - b%aspk(nzb+k) = a%aspk(i) - b%ia1(nzb+k) = iren(a%ia1(i)) - b%ia2(nzb+k) = iren(a%ia2(i)) - endif - enddo - else - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nz) then - nz = k - call psb_sp_reall(b,nzb+nz,iret) - end if - b%aspk(nzb+k) = a%aspk(i) - b%ia1(nzb+k) = (a%ia1(i)) - b%ia2(nzb+k) = (a%ia2(i)) - endif - enddo - nzb=nzb+k - end if - end if - - b%infoa(psb_nnz_) = nzb - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - end subroutine coo_dspgtrow - - - - - subroutine jad_dspgtrow(irw,a,b,append,iren,lrw) - - type(psb_dspmat_type), intent(in) :: a - integer :: irw - type(psb_dspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja(:), ka(:), indices(:), blks(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng - - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ng = a%ia2(png) ! the number of blocks - ja => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column - - - if (append) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr),blks(nr)) - nz = 0 - - do i=1,nr - indices(i)=a%pl(irw+i-1) - j=0 - blkfnd: do - j=j+1 - if(ia1(j).eq.indices(i)) then - blks(i)=j - nz=nz+ia3(j)-ia2(j) - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - nz = nz+ja(row+1)-ja(row) - exit blkfnd - else if(ia1(j).gt.indices(i)) then - blks(i)=j-1 - nz=nz+ia3(j-1)-ia2(j-1) - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - nz = nz+ja(row+1)-ja(row) - exit blkfnd - end if - end do blkfnd - end do - - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - k=0 - ! cycle over rows - do i=1,nr - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja(k_pt+1)-ja(k_pt) ! the number of rows in the block - - if(associated(iren))then - do col = ia2(blk), ia3(blk)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(ja(col)+rb) - b%ia1(nzb+k) = iren(irw+i-1) - b%ia2(nzb+k) = iren(ka(ja(col)+rb)) - end do - else - do col = ia2(blk), ia3(blk)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(ja(col)+rb) - b%ia1(nzb+k) = irw+i-1 - b%ia2(nzb+k) = ka(ja(col)+rb) - end do - end if - ! extract second part of the row from the csr tail - row=ia3(blk)+rb - if(associated(iren))then - do j=ja(row), ja(row+1)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(irw+i-1) - b%ia2(nzb+k) = iren(ka(j)) - end do - else - do j=ja(row), ja(row+1)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = irw+i-1 - b%ia2(nzb+k) = ka(j) - end do - end if - end do - - b%infoa(psb_nnz_) = nzb+k - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - b%fida='COO' - - else - ! There might be some problems - info=134 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - end if - - - - end subroutine jad_dspgtrow - - - - -end subroutine psb_dspgtrow - diff --git a/src/serial/psb_dspinfo.f90 b/src/serial/psb_dspinfo.f90 index 9fa81ca9..7874304c 100644 --- a/src/serial/psb_dspinfo.f90 +++ b/src/serial/psb_dspinfo.f90 @@ -93,7 +93,6 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) else if ((toupper(a%fida) == 'COO').or.(toupper(a%fida) == 'COI')) then if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then -!!$ write(0,*) 'Gtrow_: srtd coo',irw ! In this case we can do a binary search. nz = a%infoa(psb_nnz_) call ibsrch(ip,irw,nz,a%ia1) diff --git a/src/serial/psb_zrwextd.f90 b/src/serial/psb_zrwextd.f90 index 0e935519..daf8f144 100644 --- a/src/serial/psb_zrwextd.f90 +++ b/src/serial/psb_zrwextd.f90 @@ -58,7 +58,7 @@ subroutine psb_zrwextd(nr,a,info,b) call psb_realloc(size(a%ia1)+jb,a%ia1,info) call psb_realloc(size(a%aspk)+jb,a%aspk,info) do i=1, min(nr-a%m,b%m) - ! Should use spgtrow. + ! Should use spgtblk. ! Don't care for the time being. a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i) ja = a%ia2(a%m+i) diff --git a/src/serial/psb_zspextrow.f90 b/src/serial/psb_zspextrow.f90 deleted file mode 100644 index 7a5adbd1..00000000 --- a/src/serial/psb_zspextrow.f90 +++ /dev/null @@ -1,162 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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_zspextrow.f90 -! Subroutine: psb_zspextrow -! Gets one or more rows from a sparse matrix. -! Parameters: - -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into NZ,IA,JA,VAL in COO * -!* format. * -!* * -!***************************************************************************** -subroutine psb_zspextrow(irw,a,nz,ia,ja,val,info,iren,lrw) - use psb_spmat_type - use psb_string_mod - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, intent(inout) :: ia(:), ja(:) - complex(kind(1.d0)), intent(inout) :: val(:) - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - interface psb_spgtrow - subroutine psb_zspgtrow(irw,a,b,info,append,iren,lrw) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_zspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - end subroutine psb_zspgtrow - end interface - - integer :: lrw_, ierr(2), err_act - type(psb_zspmat_type) :: b - integer, pointer :: iren_(:) - character(len=20) :: name, ch_err - - - name='psb_sp_extrow' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPEXTROW input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b,info) - - if (present(iren)) then - call psb_spgtrow(irw,a,b,info,iren=iren,lrw=lrw_) - else - call psb_spgtrow(irw,a,b,info,lrw=lrw_) - end if - if (info /= 0) then - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (toupper(b%fida) /= 'COO') then - info=4010 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - nz = b%infoa(psb_nnz_) - - if (size(ia)>= nz) then - ia(1:nz) = b%ia1(1:nz) - else - info = 135 - ierr(1) = 4 - ierr(2) = size(ia) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - if (size(ja)>= nz) then - ja(1:nz) = b%ia2(1:nz) - else - info = 135 - ierr(1) = 5 - ierr(2) = size(ja) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - if (size(val)>= nz) then - val(1:nz) = b%aspk(1:nz) - else - info = 135 - ierr(1) = 6 - ierr(2) = size(val) - call psb_errpush(info,name,i_err=ierr) - goto 9999 - endif - - - call psb_sp_free(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return - end if - return - - -end subroutine psb_zspextrow - diff --git a/src/serial/psb_zspgtdiag.f90 b/src/serial/psb_zspgtdiag.f90 index 1d41fa05..faead301 100644 --- a/src/serial/psb_zspgtdiag.f90 +++ b/src/serial/psb_zspgtdiag.f90 @@ -51,8 +51,8 @@ subroutine psb_zspgtdiag(a,d,info) complex(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info - interface psb_spgtrow - subroutine psb_zspgtrow(irw,a,b,info,append,iren,lrw) + interface psb_spgtblk + subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -61,7 +61,7 @@ subroutine psb_zspgtdiag(a,d,info) integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info - end subroutine psb_zspgtrow + end subroutine psb_zspgtblk end interface type(psb_zspmat_type) :: tmpa @@ -102,10 +102,10 @@ subroutine psb_zspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_spgtrow(i,a,tmpa,info,lrw=irb) + call psb_spgtblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/serial/psb_zspgtrow.f90 b/src/serial/psb_zspgtrow.f90 deleted file mode 100644 index b733b921..00000000 --- a/src/serial/psb_zspgtrow.f90 +++ /dev/null @@ -1,516 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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_zspgtrow.f90 -! Subroutine: psb_zspgtrow -! Gets one or more rows from a sparse matrix. -! Parameters: - -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, once * -!* we get to actually write the code..... * -!* * -!***************************************************************************** -subroutine psb_zspgtrow(irw,a,b,info,append,iren,lrw) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_zspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - - logical :: append_ - integer, pointer :: iren_(:) - integer :: i,j,k,ip,jp,nr,idx, nz,iret,nzb, nza, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgtrow' - info = 0 - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTROW input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - if (present(iren)) then - iren_=>iren - else - iren_ => null() - end if - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - endif - - if (a%fida == 'CSR') then - call csr_zspgtrow(irw_,a,b,append_,iren_,lrw_) - - else if (a%fida == 'COO') then - call coo_zspgtrow(irw_,a,b,append_,iren_,lrw_) - - else if (a%fida == 'JAD') then - call jad_zspgtrow(irw_,a,b,append_,iren_,lrw_) - - else - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then - call psb_error() - return - end if - return - -contains - - subroutine csr_zspgtrow(irw,a,b,append,iren,lrw) - - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer :: irw - type(psb_zspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - integer :: idx,i,j ,nr,nz,nzb, row_idx - integer, pointer :: indices(:) - - if (append) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr)) - do i=1,nr - indices(i)=a%pl(irw+i-1) - nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) - end do - - if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - k=0 - if(associated(iren)) then - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(row_idx) - b%ia2(nzb+k) = iren(a%ia1(j)) - end do - end do - else - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = row_idx - b%ia2(nzb+k) = a%ia1(j) - end do - end do - end if - - b%infoa(psb_nnz_) = nzb+k - b%m = b%m+nr - b%k = max(b%k,a%k) - - else - idx = irw - - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - nr = lrw - irw + 1 - nz = a%ia2(idx+nr) - a%ia2(idx) - - if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - b%fida='COO' - - if (associated(iren)) then - k=0 - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(i) - b%ia2(nzb+k) = iren(a%ia1(j)) - end do - enddo - else - k=0 - - do i=irw,lrw - - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - b%ia1(nzb+k) = i - b%ia2(nzb+k) = a%ia1(j) - b%aspk(nzb+k) = a%aspk(j) -!!$ write(0,*) 'csr_gtrow: in:',a%aspk(j),i,a%ia1(j) - end do - enddo - end if - b%infoa(psb_nnz_) = nzb+nz - if (a%pr(1) /= 0) then - write(0,*) 'Feeling lazy today, Right Permutation will have to wait' - endif - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - - endif - - end subroutine csr_zspgtrow - - subroutine coo_zspgtrow(irw,a,b,append,iren,lrw) - - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer :: irw - type(psb_zspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - nza = a%infoa(psb_nnz_) - if (a%pl(1) /= 0) then - write(0,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' - idx = -1 - else - idx = irw - endif - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - - if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then - ! In this case we can do a binary search. - do - call ibsrch(ip,irw,nza,a%ia1) - if (ip /= -1) exit - irw = irw + 1 - if (irw > lrw) then - write(0,*) 'Warning : did not find any rows. Is this an error? ',irw,lrw,idx - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia1(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - call ibsrch(jp,lrw,nza,a%ia1) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(0,*) 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia1(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nz = jp - ip +1 - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - b%fida='COO' - if (associated(iren)) then - do i=ip,jp - nzb = nzb + 1 - b%aspk(nzb) = a%aspk(i) - b%ia1(nzb) = iren(a%ia1(i)) - b%ia2(nzb) = iren(a%ia2(i)) - enddo - else - do i=ip,jp - nzb = nzb + 1 - b%aspk(nzb) = a%aspk(i) - b%ia1(nzb) = a%ia1(i) - b%ia2(nzb) = a%ia2(i) - enddo - end if - end if - - else - - nz = (nza*(lrw-irw+1))/max(a%m,1) - - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - if (associated(iren)) then - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nz) then - nz = k - call psb_sp_reall(b,nzb+nz,iret) - end if - b%aspk(nzb+k) = a%aspk(i) - b%ia1(nzb+k) = iren(a%ia1(i)) - b%ia2(nzb+k) = iren(a%ia2(i)) - endif - enddo - else - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nz) then - nz = k - call psb_sp_reall(b,nzb+nz,iret) - end if - b%aspk(nzb+k) = a%aspk(i) - b%ia1(nzb+k) = (a%ia1(i)) - b%ia2(nzb+k) = (a%ia2(i)) - endif - enddo - nzb=nzb+k - end if - end if - - b%infoa(psb_nnz_) = nzb - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - end subroutine coo_zspgtrow - - - - - subroutine jad_zspgtrow(irw,a,b,append,iren,lrw) - - type(psb_zspmat_type), intent(in) :: a - integer :: irw - type(psb_zspmat_type), intent(inout) :: b - logical, intent(in) :: append - integer, pointer :: iren(:) - integer :: lrw - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja(:), ka(:), indices(:), blks(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng - - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ng = a%ia2(png) ! the number of blocks - ja => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column - - - if (append) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr),blks(nr)) - nz = 0 - - do i=1,nr - indices(i)=a%pl(irw+i-1) - j=0 - blkfnd: do - j=j+1 - if(ia1(j).eq.indices(i)) then - blks(i)=j - nz=nz+ia3(j)-ia2(j) - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - nz = nz+ja(row+1)-ja(row) - exit blkfnd - else if(ia1(j).gt.indices(i)) then - blks(i)=j-1 - nz=nz+ia3(j-1)-ia2(j-1) - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - nz = nz+ja(row+1)-ja(row) - exit blkfnd - end if - end do blkfnd - end do - - if (size(b%ia1) < nzb+nz) then - call psb_sp_reall(b,nzb+nz,iret) - endif - - k=0 - ! cycle over rows - do i=1,nr - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja(k_pt+1)-ja(k_pt) ! the number of rows in the block - - if(associated(iren))then - do col = ia2(blk), ia3(blk)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(ja(col)+rb) - b%ia1(nzb+k) = iren(irw+i-1) - b%ia2(nzb+k) = iren(ka(ja(col)+rb)) - end do - else - do col = ia2(blk), ia3(blk)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(ja(col)+rb) - b%ia1(nzb+k) = irw+i-1 - b%ia2(nzb+k) = ka(ja(col)+rb) - end do - end if - ! extract second part of the row from the csr tail - row=ia3(blk)+rb - if(associated(iren))then - do j=ja(row), ja(row+1)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = iren(irw+i-1) - b%ia2(nzb+k) = iren(ka(j)) - end do - else - do j=ja(row), ja(row+1)-1 - k=k+1 - b%aspk(nzb+k) = a%aspk(j) - b%ia1(nzb+k) = irw+i-1 - b%ia2(nzb+k) = ka(j) - end do - end if - end do - - b%infoa(psb_nnz_) = nzb+k - b%m = b%m+lrw-irw+1 - b%k = max(b%k,a%k) - b%fida='COO' - - else - ! There might be some problems - info=134 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - end if - - - - end subroutine jad_zspgtrow - - - - -end subroutine psb_zspgtrow - diff --git a/src/serial/psb_zspinfo.f90 b/src/serial/psb_zspinfo.f90 index e63969ba..c4c4092e 100644 --- a/src/serial/psb_zspinfo.f90 +++ b/src/serial/psb_zspinfo.f90 @@ -93,7 +93,6 @@ subroutine psb_zspinfo(ireq,a,ires,info,iaux) else if ((toupper(a%fida) == 'COO').or.(toupper(a%fida) == 'COI')) then if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then -!!$ write(0,*) 'Gtrow_: srtd coo',irw ! In this case we can do a binary search. nz = a%infoa(psb_nnz_) call ibsrch(ip,irw,nz,a%ia1) diff --git a/src/tools/psb_dcdovrbld.f90 b/src/tools/psb_dcdovrbld.f90 index 60a8406a..873dc475 100644 --- a/src/tools/psb_dcdovrbld.f90 +++ b/src/tools/psb_dcdovrbld.f90 @@ -409,10 +409,10 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& end if End If - call psb_spgtrow(idx,a,blk,info) + call psb_spgtblk(idx,a,blk,info) if (info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/tools/psb_dsphalo.f90 b/src/tools/psb_dsphalo.f90 index 0c801f54..79f8a461 100644 --- a/src/tools/psb_dsphalo.f90 +++ b/src/tools/psb_dsphalo.f90 @@ -33,7 +33,7 @@ !***************************************************************************** !* * !* This routine does the retrieval of remote matrix rows. * -!* Note that retrieval is done through GTROW, therefore it should work * +!* Note that retrieval is done through GTBLK, therefore it should work * !* for any format. * !* Currently the output is BLK%FIDA='CSR' but it would take little * !* work to change that; the pieces are transferred in COO format * @@ -224,10 +224,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) goto 9999 end if !!$ write(0,*) me,'Getting row ',idx,n_elem - call psb_spgtrow(idx,a,tmp,info,append=.true.) + call psb_spgtblk(idx,a,tmp,info,append=.true.) if (info /= 0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/tools/psb_zcdovrbld.f90 b/src/tools/psb_zcdovrbld.f90 index 18327842..235074b8 100644 --- a/src/tools/psb_zcdovrbld.f90 +++ b/src/tools/psb_zcdovrbld.f90 @@ -409,10 +409,10 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& end if End If - call psb_spgtrow(idx,a,blk,info) + call psb_spgtblk(idx,a,blk,info) if (info.ne.0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/tools/psb_zsphalo.f90 b/src/tools/psb_zsphalo.f90 index 1683b860..492c624e 100644 --- a/src/tools/psb_zsphalo.f90 +++ b/src/tools/psb_zsphalo.f90 @@ -33,7 +33,7 @@ !***************************************************************************** !* * !* This routine does the retrieval of remote matrix rows. * -!* Note that retrieval is done through GTROW, therefore it should work * +!* Note that retrieval is done through GTBLK, therefore it should work * !* for any format. * !* Currently the output is BLK%FIDA='CSR' but it would take little * !* work to change that; the pieces are transferred in COO format * @@ -224,10 +224,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) goto 9999 end if !!$ write(0,*) me,'Getting row ',idx,n_elem - call psb_spgtrow(idx,a,tmp,info,append=.true.) + call psb_spgtblk(idx,a,tmp,info,append=.true.) if (info /= 0) then info=4010 - ch_err='psb_spgtrow' + ch_err='psb_spgtblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if