diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index 376ca201..49684147 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -80,8 +80,8 @@ contains ! also changes error action to "return" subroutine psb_erractionsave(err_act) integer, intent(out) :: err_act - err_act=err_action - err_action=act_ret + err_act = err_action + err_action = act_ret end subroutine psb_erractionsave diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index e600d3d5..c392fd7b 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -136,6 +136,14 @@ module psb_serial_mod end subroutine psb_zcsmm end interface + interface psb_cest + subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) + integer, intent(in) :: m,n,nnz,iup + integer, intent(out) :: lia1, lia2, lar, info + character, intent(inout) :: afmt*5 + end subroutine psb_cest + end interface + interface psb_fixcoo subroutine psb_dfixcoo(a,info,idir) use psb_spmat_type @@ -417,7 +425,7 @@ module psb_serial_mod end interface interface psb_sp_getrow - subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) + subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,bw) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a integer, intent(in) :: irw @@ -427,6 +435,7 @@ module psb_serial_mod integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info + type(psb_dspmat_type), intent(inout), optional, target :: bw end subroutine psb_dspgetrow subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) use psb_spmat_type diff --git a/base/serial/psb_dcsdp.f90 b/base/serial/psb_dcsdp.f90 index d7e4470f..6200af3f 100644 --- a/base/serial/psb_dcsdp.f90 +++ b/base/serial/psb_dcsdp.f90 @@ -48,7 +48,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) use psb_error_mod use psb_spmat_type use psb_string_mod - + use psb_serial_mod, psb_protect_name => psb_dcsdp implicit none !....Parameters... Type(psb_dspmat_type), intent(in) :: A @@ -70,14 +70,6 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - interface psb_cest - subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) - integer, intent(in) :: m,n,nnz,iup - integer, intent(out) :: lia1, lia2, lar, info - character, intent(inout) :: afmt*5 - end subroutine psb_cest - end interface - name='psb_csdp' info = 0 call psb_erractionsave(err_act) diff --git a/base/serial/psb_dcsrws.f90 b/base/serial/psb_dcsrws.f90 index 6b2ea0a0..07b50100 100644 --- a/base/serial/psb_dcsrws.f90 +++ b/base/serial/psb_dcsrws.f90 @@ -42,7 +42,7 @@ subroutine psb_dcsrws(rw,a,info,trans) integer :: info character, optional :: trans - Interface dcsrws + Interface subroutine dcsrws(trans,m,n,fida,descra,a,ia1,ia2,& & infoa,rowsum,ierror) integer, intent(in) :: m,n diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index ea04d807..61595928 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -41,27 +41,14 @@ subroutine psb_dnumbmm(a,b,c) use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_dnumbmm implicit none type(psb_dspmat_type) :: a,b,c real(kind(1.d0)), allocatable :: temp(:) integer :: info + logical :: csra, csrb - 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 - 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 - end subroutine psb_dspgetrow - end interface - - allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) if (info /= 0) then return @@ -71,7 +58,10 @@ subroutine psb_dnumbmm(a,b,c) ! Note: we still have to test about possible performance hits. ! ! - if (.true.) then + csra = (toupper(a%fida(1:3))=='CSR') + csrb = (toupper(b%fida(1:3))=='CSR') + + if (csra.and.csrb) then call numbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,a%aspk,& & b%ia2,b%ia1,0,b%aspk,& & c%ia2,c%ia1,0,c%aspk,temp) @@ -94,7 +84,7 @@ contains real(kind(1.d0)), allocatable :: aval(:),bval(:) integer :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,ii,minlm,minmn,minln real(kind(1.d0)) :: ajj - + type(psb_dspmat_type) :: w n = a%m m = a%k @@ -114,7 +104,7 @@ contains minmn = min(m,n) do i = 1,n - call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info,bw=w) do jj=1, nazr j=iacl(jj) @@ -125,7 +115,7 @@ contains return endif - call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info,bw=w) do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 index a0cf2ab4..19e52b1c 100644 --- a/base/serial/psb_dspgetrow.f90 +++ b/base/serial/psb_dspgetrow.f90 @@ -39,7 +39,7 @@ !* format. * !* * !***************************************************************************** -subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) +subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,bw) use psb_spmat_type use psb_string_mod use psb_serial_mod, psb_protect_name => psb_dspgetrow @@ -52,19 +52,22 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) integer, intent(in), target, optional :: iren(:) integer, intent(in), optional :: lrw integer, intent(out) :: info + type(psb_dspmat_type), intent(inout), optional, target :: bw integer :: lrw_, ierr(5), err_act - type(psb_dspmat_type) :: b + type(psb_dspmat_type), target :: b + type(psb_dspmat_type), pointer :: b_ + integer, pointer :: iren_(:) character(len=20) :: name, ch_err - name='psb_sp_getrow' + name = 'psb_sp_getrow' info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) +!!$ call psb_erractionsave(err_act) +!!$ call psb_set_erraction(0) + - call psb_nullify_sp(b) if (present(lrw)) then lrw_ = lrw @@ -75,13 +78,26 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) write(0,*) 'SPGETROW input error: fixing lrw',irw,lrw_ lrw_ = irw end if - call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b,info) + if (present(bw)) then + b_ => bw + else + b_ => b + end if + call psb_nullify_sp(b_) + if (.not.(allocated(b_%aspk).and.allocated(b_%ia1).and.& + & allocated(b_%ia2))) then + write(0,*) 'First allocation for B in SPGETROW' + call psb_sp_all(lrw_-irw+1,lrw_-irw+1,b_,info) + end if if (present(iren)) then - call psb_sp_getblk(irw,a,b,info,iren=iren,lrw=lrw_) + call psb_sp_getblk(irw,a,b_,info,iren=iren,lrw=lrw_) else - call psb_sp_getblk(irw,a,b,info,lrw=lrw_) + call psb_sp_getblk(irw,a,b_,info,lrw=lrw_) end if + + + if (info /= 0) then info=136 ch_err=a%fida(1:3) @@ -89,17 +105,17 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) goto 9999 end if - if (toupper(b%fida) /= 'COO') then + 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_) + nz = b_%infoa(psb_nnz_) if (size(ia)>= nz) then - ia(1:nz) = b%ia1(1:nz) + ia(1:nz) = b_%ia1(1:nz) else info = 135 ierr(1) = 4 @@ -109,7 +125,7 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) endif if (size(ja)>= nz) then - ja(1:nz) = b%ia2(1:nz) + ja(1:nz) = b_%ia2(1:nz) else info = 135 ierr(1) = 5 @@ -119,7 +135,7 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) endif if (size(val)>= nz) then - val(1:nz) = b%aspk(1:nz) + val(1:nz) = b_%aspk(1:nz) else info = 135 ierr(1) = 6 @@ -127,15 +143,16 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) call psb_errpush(info,name,i_err=ierr) goto 9999 endif + +!!$ call psb_sp_free(b,info) - call psb_sp_free(b,info) - - call psb_erractionrestore(err_act) +!!$ call psb_erractionrestore(err_act) return 9999 continue - call psb_erractionrestore(err_act) +!!$ call psb_erractionrestore(err_act) + call psb_erractionsave(err_act) if (err_act.eq.psb_act_abort_) then call psb_error() return diff --git a/base/serial/psb_dspgtblk.f90 b/base/serial/psb_dspgtblk.f90 index 09dddf30..0777fd6c 100644 --- a/base/serial/psb_dspgtblk.f90 +++ b/base/serial/psb_dspgtblk.f90 @@ -61,7 +61,7 @@ subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) name='psb_spgtblk' info = 0 - call psb_erractionsave(err_act) +!!$ call psb_erractionsave(err_act) irw_ = irw if (present(lrw)) then @@ -79,7 +79,7 @@ subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) append_=.false. endif if (present(iren)) then - iren_=>iren + iren_ => iren else iren_ => null() end if @@ -110,11 +110,12 @@ subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) end if - call psb_erractionrestore(err_act) +!!$ call psb_erractionrestore(err_act) return 9999 continue - call psb_erractionrestore(err_act) +!!$ call psb_erractionrestore(err_act) + call psb_erractionsave(err_act) if (err_act.eq.psb_act_abort_) then call psb_error() return @@ -156,6 +157,7 @@ contains end do if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then +!!$ write(0,*) 'Realloc in gtblk 1',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) endif @@ -197,6 +199,7 @@ contains nz = a%ia2(idx+nr) - a%ia2(idx) if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then +!!$ write(0,*) 'Realloc in gtblk 2',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) endif b%fida='COO' @@ -310,6 +313,7 @@ contains ! Now do the copy. nz = jp - ip +1 if (size(b%ia1) < nzb+nz) then +!!$ write(0,*) 'Realloc in gtblk 3',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) endif b%fida='COO' @@ -335,6 +339,7 @@ contains nz = (nza*(lrw-irw+1))/max(a%m,1) if (size(b%ia1) < nzb+nz) then +!!$ write(0,*) 'Realloc in gtblk 4',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) endif @@ -345,6 +350,7 @@ contains k = k + 1 if (k > nz) then nz = k +!!$ write(0,*) 'Realloc in gtblk 5',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) end if b%aspk(nzb+k) = a%aspk(i) @@ -359,6 +365,7 @@ contains k = k + 1 if (k > nz) then nz = k +!!$ write(0,*) 'Realloc in gtblk 6',size(b%ia1),size(b%ia2),size(b%aspk),nzb,nz call psb_sp_reall(b,nzb+nz,iret) end if b%aspk(nzb+k) = a%aspk(i) diff --git a/base/serial/psb_dspgtdiag.f90 b/base/serial/psb_dspgtdiag.f90 index e9065280..9e050925 100644 --- a/base/serial/psb_dspgtdiag.f90 +++ b/base/serial/psb_dspgtdiag.f90 @@ -34,9 +34,6 @@ !***************************************************************************** !* * -!* 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_dspgtdiag(a,d,info) @@ -45,25 +42,13 @@ subroutine psb_dspgtdiag(a,d,info) use psb_spmat_type use psb_error_mod use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_dspgtdiag implicit none type(psb_dspmat_type), intent(in) :: a real(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info - 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 - type(psb_dspmat_type), intent(inout) :: b - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_dspgtblk - end interface - type(psb_dspmat_type) :: tmpa integer :: i,j,k,nr, nz, err_act, ii, rng, irb, nrb character(len=20) :: name, ch_err @@ -102,10 +87,10 @@ subroutine psb_dspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_spgtblk(i,a,tmpa,info,lrw=irb) + call psb_sp_getblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 - ch_err='psb_spgtblk' + ch_err='psb_sp_getblk' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index e84e82b2..bcaeab5c 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -41,7 +41,7 @@ subroutine psb_dsymbmm(a,b,c,info) use psb_spmat_type use psb_string_mod - use psb_serial_mod, only : psb_msort + use psb_serial_mod, psb_protect_name => psb_dsymbmm implicit none type(psb_dspmat_type) :: a,b,c @@ -56,41 +56,14 @@ subroutine psb_dsymbmm(a,b,c,info) integer, allocatable :: ic(:),jc(:) end subroutine symbmm end interface - 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 - 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 - end subroutine psb_dspgetrow - end interface - - character(len=20) :: name, ch_err - integer :: err_act + character(len=20) :: name, ch_err + integer :: err_act + logical :: csra, csrb name='psb_symbmm' call psb_erractionsave(err_act) - select case(toupper(a%fida(1:3))) - case ('CSR') - case default - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - select case(toupper(b%fida(1:3))) - case ('CSR') - case default - info=136 - ch_err=b%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select + csra = (toupper(a%fida(1:3))=='CSR') + csrb = (toupper(b%fida(1:3))=='CSR') if (b%m /= a%k) then write(0,*) 'Mismatch in SYMBMM: ',a%m,a%k,b%m,b%k @@ -105,7 +78,7 @@ subroutine psb_dsymbmm(a,b,c,info) ! Note: we need to test whether there is a performance impact ! in not using the original Douglas & Bank code. ! - if (.true.) then + if (csra.and.csrb) then call symbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,& & b%ia2,b%ia1,0,& & c%ia2,c%ia1,0,itemp) @@ -140,6 +113,7 @@ contains integer, allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) real(kind(1.d0)), allocatable :: aval(:),bval(:) integer :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,ii,minlm,minmn + type(psb_dspmat_type) :: w n = a%m @@ -169,7 +143,7 @@ contains main: do i=1,n istart=-1 length=0 - call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info,bw=w) do jj=1, nazr j=iacl(jj) @@ -179,7 +153,7 @@ contains info = 1 return endif - call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info,bw=w) do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn diff --git a/base/serial/psb_zcsdp.f90 b/base/serial/psb_zcsdp.f90 index 6bfec0c0..6a8d28df 100644 --- a/base/serial/psb_zcsdp.f90 +++ b/base/serial/psb_zcsdp.f90 @@ -48,7 +48,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) use psb_error_mod use psb_spmat_type use psb_string_mod - + use psb_serial_mod, psb_protect_name => psb_zcsdp implicit none !....Parameters... Type(psb_zspmat_type), intent(in) :: A @@ -70,14 +70,6 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) logical, parameter :: debug=.false. character(len=20) :: name, ch_err - interface psb_cest - subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) - integer, intent(in) :: m,n,nnz,iup - integer, intent(out) :: lia1, lia2, lar, info - character, intent(inout) :: afmt*5 - end subroutine psb_cest - end interface - name='psb_csdp' info = 0 call psb_erractionsave(err_act) diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index 53f4f031..845ee0ae 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -28,7 +28,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: psb_znumbmm.f90 +! File: psb_dnumbmm.f90 ! Subroutine: ! Parameters: ! @@ -41,27 +41,14 @@ subroutine psb_znumbmm(a,b,c) use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_znumbmm implicit none type(psb_zspmat_type) :: a,b,c complex(kind(1.d0)), allocatable :: temp(:) integer :: info + logical :: csra, csrb - interface psb_sp_getrow - 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 - 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 - end subroutine psb_zspgetrow - end interface - - allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) if (info /= 0) then return @@ -71,7 +58,10 @@ subroutine psb_znumbmm(a,b,c) ! Note: we still have to test about possible performance hits. ! ! - if (.true.) then + csra = (toupper(a%fida(1:3))=='CSR') + csrb = (toupper(b%fida(1:3))=='CSR') + + if (csra.and.csrb) then call znumbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,a%aspk,& & b%ia2,b%ia1,0,b%aspk,& & c%ia2,c%ia1,0,c%aspk,temp) diff --git a/base/serial/psb_zspgtdiag.f90 b/base/serial/psb_zspgtdiag.f90 index 27225733..31720499 100644 --- a/base/serial/psb_zspgtdiag.f90 +++ b/base/serial/psb_zspgtdiag.f90 @@ -34,9 +34,6 @@ !***************************************************************************** !* * -!* 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_zspgtdiag(a,d,info) @@ -45,25 +42,13 @@ subroutine psb_zspgtdiag(a,d,info) use psb_spmat_type use psb_error_mod use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_zspgtdiag implicit none type(psb_zspmat_type), intent(in) :: a complex(kind(1.d0)), intent(inout) :: d(:) integer, intent(out) :: info - 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 - type(psb_zspmat_type), intent(inout) :: b - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - integer, intent(out) :: info - end subroutine psb_zspgtblk - end interface - type(psb_zspmat_type) :: tmpa integer :: i,j,k,nr, nz, err_act, ii, rng, irb, nrb character(len=20) :: name, ch_err @@ -102,7 +87,7 @@ subroutine psb_zspgtdiag(a,d,info) write(0,*)'in spgtdiag' do i=1, rng, nrb irb=min(i+nrb-1,rng) - call psb_spgtblk(i,a,tmpa,info,lrw=irb) + call psb_sp_getblk(i,a,tmpa,info,lrw=irb) if(info.ne.0) then info=4010 ch_err='psb_spgtblk' diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 221c7b36..d965f58f 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -41,6 +41,7 @@ subroutine psb_zsymbmm(a,b,c,info) use psb_spmat_type use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zsymbmm implicit none type(psb_zspmat_type) :: a,b,c @@ -56,40 +57,14 @@ subroutine psb_zsymbmm(a,b,c,info) end subroutine symbmm end interface - interface psb_sp_getrow - 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 - 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 - end subroutine psb_zspgetrow - end interface character(len=20) :: name, ch_err integer :: err_act + logical :: csra, csrb name='psb_symbmm' call psb_erractionsave(err_act) - select case(toupper(a%fida(1:3))) - case ('CSR') - case default - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - select case(toupper(b%fida(1:3))) - case ('CSR') - case default - info=136 - ch_err=b%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select + csra = (toupper(a%fida(1:3))=='CSR') + csrb = (toupper(b%fida(1:3))=='CSR') if (b%m /= a%k) then write(0,*) 'Mismatch in SYMBMM: ',a%m,a%k,b%m,b%k @@ -100,12 +75,11 @@ subroutine psb_zsymbmm(a,b,c,info) endif nze = max(a%m+1,2*a%m) call psb_sp_reall(c,nze,info) - ! ! Note: we need to test whether there is a performance impact ! in not using the original Douglas & Bank code. ! - if (.true.) then + if (csra.and.csrb) then call symbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,& & b%ia2,b%ia1,0,& & c%ia2,c%ia1,0,itemp) @@ -113,6 +87,7 @@ subroutine psb_zsymbmm(a,b,c,info) call inner_symbmm(a,b,c,itemp,info) endif call psb_realloc(size(c%ia1),c%aspk,info) + c%pl(1) = 0 c%pr(1) = 0 c%m=a%m