fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-18 11:52:11 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/psblas/psb_cspmm.f90
 base/psblas/psb_cspsm.f90
 base/psblas/psb_dspmm.f90
 base/psblas/psb_dspsm.f90
 base/psblas/psb_sspmm.f90
 base/psblas/psb_sspsm.f90
 base/psblas/psb_zspmm.f90
 base/psblas/psb_zspsm.f90
 base/tools/psb_cdins.f90
 base/tools/psb_cspins.f90
 base/tools/psb_dspins.f90
 base/tools/psb_loc_to_glob.f90
 base/tools/psb_sspins.f90
 base/tools/psb_zspins.f90

Performance fixes in spins/cdins, take 1. 
Vector checks in _sm, _mm _vect
This commit is contained in:
Salvatore Filippone
2013-10-01 14:45:45 +00:00
parent c407209ca7
commit 775b1de8d6
14 changed files with 57 additions and 234 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/psblas/psb_cspmm.f90
-1
View File
@@ -765,7 +765,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
base/psblas/psb_cspsm.f90
+6 -41
View File
@@ -606,15 +606,6 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
endif
! just this case right now
ia = 1
ja = 1
ix = 1
iy = 1
ik = 1
jx = 1
jy = 1
if (present(choice)) then
choice_ = choice
else
@@ -645,10 +636,13 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols()
lldx = x%get_nrows()
lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if((lldx < ncol).or.(lldy < ncol)) then
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -680,35 +674,6 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
iwork(1)=0.d0
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == psb_success_) &
& call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx)
if (info == psb_success_)&
& call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(ja /= ix) then
! this case is not yet implemented
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
base/psblas/psb_dspmm.f90
-1
View File
@@ -765,7 +765,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
base/psblas/psb_dspsm.f90
+6 -41
View File
@@ -606,15 +606,6 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
endif
! just this case right now
ia = 1
ja = 1
ix = 1
iy = 1
ik = 1
jx = 1
jy = 1
if (present(choice)) then
choice_ = choice
else
@@ -645,10 +636,13 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols()
lldx = x%get_nrows()
lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if((lldx < ncol).or.(lldy < ncol)) then
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -680,35 +674,6 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
iwork(1)=0.d0
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == psb_success_) &
& call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx)
if (info == psb_success_)&
& call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(ja /= ix) then
! this case is not yet implemented
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
base/psblas/psb_sspmm.f90
-1
View File
@@ -765,7 +765,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
base/psblas/psb_sspsm.f90
+6 -41
View File
@@ -606,15 +606,6 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
endif
! just this case right now
ia = 1
ja = 1
ix = 1
iy = 1
ik = 1
jx = 1
jy = 1
if (present(choice)) then
choice_ = choice
else
@@ -645,10 +636,13 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols()
lldx = x%get_nrows()
lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if((lldx < ncol).or.(lldy < ncol)) then
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -680,35 +674,6 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
iwork(1)=0.d0
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == psb_success_) &
& call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx)
if (info == psb_success_)&
& call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(ja /= ix) then
! this case is not yet implemented
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
base/psblas/psb_zspmm.f90
-1
View File
@@ -765,7 +765,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
base/psblas/psb_zspsm.f90
+6 -41
View File
@@ -606,15 +606,6 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
endif
! just this case right now
ia = 1
ja = 1
ix = 1
iy = 1
ik = 1
jx = 1
jy = 1
if (present(choice)) then
choice_ = choice
else
@@ -645,10 +636,13 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols()
lldx = x%get_nrows()
lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if((lldx < ncol).or.(lldy < ncol)) then
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -680,35 +674,6 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
iwork(1)=0.d0
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == psb_success_) &
& call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx)
if (info == psb_success_)&
& call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if(ja /= ix) then
! this case is not yet implemented
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
base/tools/psb_cdins.f90
-10
View File
@@ -121,9 +121,6 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == psb_success_) &
& call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$ call psi_idx_cnv(nz,ia,ila,desc_a,info,owned=.true.)
!!$ if (info == psb_success_) &
!!$ & call psb_cdins(nz,ja,desc_a,info,jla=jla,mask=(ila(1:nz)>0))
else
if (present(ila).or.present(jla)) then
write(psb_err_unit,*) 'Inconsistent call : ',present(ila),present(jla)
@@ -139,10 +136,6 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
jla_(1:nz) = ja(1:nz)
call desc_a%indxmap%g2lip_ins(jla_(1:nz),info,mask=(ila_(1:nz)>0))
end if
!!$ call psi_idx_cnv(nz,ia,ila_,desc_a,info,owned=.true.)
!!$ if (info == psb_success_) &
!!$ & call psb_cdins(nz,ja,desc_a,info,mask=(ila_(1:nz)>0))
deallocate(ila_)
end if
if (info /= psb_success_) goto 9999
@@ -256,9 +249,7 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx)
end if
if (present(jla)) then
!!$ call psi_idx_ins_cnv(nz,ja,jla,desc,info,mask=mask,lidx=lidx)
call desc%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=mask,lidx=lidx)
else
allocate(jla_(nz),stat=info)
if (info /= psb_success_) then
@@ -266,7 +257,6 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx)
call psb_errpush(info,name)
goto 9999
end if
!!$ call psi_idx_ins_cnv(nz,ja,jla_,desc,info,mask=mask,lidx=lidx)
call desc%indxmap%g2l_ins(ja(1:nz),jla_(1:nz),info,mask=mask,lidx=lidx)
deallocate(jla_)
end if
base/tools/psb_cspins.f90
+7 -15
View File
@@ -75,12 +75,6 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
name = 'psb_cspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@@ -133,7 +127,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
& a_err='allocate',i_err=ierr)
goto 9999
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -178,10 +174,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
ila(1:nz) = ia(1:nz)
jla(1:nz) = ja(1:nz)
call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I')
call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I')
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -282,11 +276,9 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
& a_err='allocate',i_err=ierr)
goto 9999
end if
ila(1:nz) = ia(1:nz)
call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
base/tools/psb_dspins.f90
+1 -11
View File
@@ -75,12 +75,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
name = 'psb_dspins'
call psb_erractionsave(err_act)
!!$ if (.not.desc_a%is_ok()) then
!!$ info = psb_err_invalid_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@@ -133,7 +127,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
& a_err='allocate',i_err=ierr)
goto 9999
end if
!!$ call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla,good_desc=.true.)
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
@@ -180,8 +174,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
!!$ call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_a,info,iact='I')
!!$ call psb_glob_to_loc(ja(1:nz),jla(1:nz),desc_a,info,iact='I')
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
@@ -286,8 +278,6 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
base/tools/psb_loc_to_glob.f90
+11
View File
@@ -66,6 +66,12 @@ subroutine psb_loc_to_glob2v(x,y,desc_a,info,iact)
info=psb_success_
name='psb_loc_to_glob2'
call psb_erractionsave(err_act)
if (.not.desc_a%is_valid()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(iact)) then
act=iact
@@ -171,6 +177,11 @@ subroutine psb_loc_to_glob1v(x,desc_a,info,iact)
info=psb_success_
name='psb_loc_to_glob'
call psb_erractionsave(err_act)
if (.not.desc_a%is_valid()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(iact)) then
act=iact
base/tools/psb_sspins.f90
+7 -15
View File
@@ -75,12 +75,6 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
name = 'psb_sspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@@ -133,7 +127,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
& a_err='allocate',i_err=ierr)
goto 9999
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -178,10 +174,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
ila(1:nz) = ia(1:nz)
jla(1:nz) = ja(1:nz)
call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I')
call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I')
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -282,11 +276,9 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
& a_err='allocate',i_err=ierr)
goto 9999
end if
ila(1:nz) = ia(1:nz)
call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
base/tools/psb_zspins.f90
+7 -15
View File
@@ -75,12 +75,6 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
name = 'psb_zspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@@ -133,7 +127,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
& a_err='allocate',i_err=ierr)
goto 9999
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -178,10 +174,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
ila(1:nz) = ia(1:nz)
jla(1:nz) = ja(1:nz)
call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I')
call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I')
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -282,11 +276,9 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
& a_err='allocate',i_err=ierr)
goto 9999
end if
ila(1:nz) = ia(1:nz)
call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info