fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3-integer8:

Browse Source 
base/serial/impl/psb_c_base_mat_impl.f90
 base/serial/impl/psb_c_coo_impl.f90
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_d_base_mat_impl.f90
 base/serial/impl/psb_d_coo_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_s_base_mat_impl.f90
 base/serial/impl/psb_s_coo_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_z_base_mat_impl.f90
 base/serial/impl/psb_z_coo_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90

Merged changes in impl subdir.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 1d3eb5c24f
commit a3931c2b6d
16 changed files with 1388 additions and 780 deletions
Show Stats Download Patch File Download Diff File

110
base/serial/impl/psb_c_base_mat_impl.f90
Unescape Escape View File

@ -20,6 +20,7 @@ subroutine psb_c_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -47,6 +48,7 @@ subroutine psb_c_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -75,6 +77,7 @@ subroutine psb_c_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -100,6 +103,7 @@ subroutine psb_c_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -126,6 +130,7 @@ subroutine psb_c_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -153,6 +158,7 @@ subroutine psb_c_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -181,6 +187,7 @@ subroutine psb_c_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -206,6 +213,7 @@ subroutine psb_c_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -232,6 +240,7 @@ subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -268,6 +277,7 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -309,6 +319,7 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -367,6 +378,7 @@ subroutine psb_c_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -448,6 +460,7 @@ subroutine psb_c_base_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -475,6 +488,7 @@ subroutine psb_c_base_transp_2mat(a,b)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transp'
call psb_erractionsave(err_act)
@ -489,7 +503,8 @@ subroutine psb_c_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -513,6 +528,7 @@ subroutine psb_c_base_transc_2mat(a,b)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transc'
call psb_erractionsave(err_act)
@ -527,7 +543,8 @@ subroutine psb_c_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -550,6 +567,7 @@ subroutine psb_c_base_transp_1mat(a)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transp'
call psb_erractionsave(err_act)
@ -583,6 +601,7 @@ subroutine psb_c_base_transc_1mat(a)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transc'
call psb_erractionsave(err_act)
@ -634,6 +653,7 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@ -663,6 +683,7 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmv'
logical, parameter :: debug=.false.
@ -693,6 +714,7 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_cssm'
logical, parameter :: debug=.false.
@ -722,6 +744,7 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_cssv'
logical, parameter :: debug=.false.
@ -755,6 +778,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_spk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -770,13 +794,15 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -795,8 +821,9 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -818,8 +845,9 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -843,7 +871,8 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -890,6 +919,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_spk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -905,13 +935,15 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -930,8 +962,9 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -948,8 +981,9 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -973,7 +1007,8 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1038,6 +1073,7 @@ subroutine psb_c_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_scals'
logical, parameter :: debug=.false.
@ -1066,6 +1102,7 @@ subroutine psb_c_base_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_scal'
logical, parameter :: debug=.false.
@ -1095,6 +1132,7 @@ function psb_c_base_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1124,6 +1162,7 @@ function psb_c_base_csnmi(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
@ -1153,6 +1192,7 @@ function psb_c_base_csnm1(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
logical, parameter :: debug=.false.
@ -1180,6 +1220,7 @@ subroutine psb_c_base_rowsum(d,a)
complex(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1206,6 +1247,7 @@ subroutine psb_c_base_arwsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1232,6 +1274,7 @@ subroutine psb_c_base_colsum(d,a)
complex(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1258,6 +1301,7 @@ subroutine psb_c_base_aclsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1288,6 +1332,7 @@ subroutine psb_c_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1359,6 +1404,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_c_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -1374,13 +1420,15 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (x%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (y%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1402,8 +1450,9 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1422,8 +1471,9 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1450,7 +1500,8 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1494,6 +1545,7 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_vect_sv'
logical, parameter :: debug=.false.

146
base/serial/impl/psb_c_coo_impl.f90
Unescape Escape View File

@ -9,6 +9,7 @@ subroutine psb_c_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -18,7 +19,8 @@ subroutine psb_c_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
d(:) = czero
@ -57,6 +59,7 @@ subroutine psb_c_coo_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -66,7 +69,8 @@ subroutine psb_c_coo_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -99,6 +103,7 @@ subroutine psb_c_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -132,6 +137,7 @@ subroutine psb_c_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -166,6 +172,7 @@ subroutine psb_c_coo_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -197,6 +204,7 @@ subroutine psb_c_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -246,6 +254,7 @@ subroutine psb_c_coo_trim(a)
implicit none
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -281,6 +290,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -288,12 +298,14 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -303,7 +315,8 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -312,7 +325,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
if (info == psb_success_) then
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_nzeros(0)
call a%set_nzeros(izero)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_unit(.false.)
@ -347,6 +360,7 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_print'
logical, parameter :: debug=.false.
@ -471,6 +485,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@ -499,13 +514,15 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -528,7 +545,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
if (beta == czero) then
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
& x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -542,7 +559,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
& x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -829,6 +846,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -851,13 +869,15 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1175,6 +1195,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1207,13 +1228,15 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
nnz = a%get_nzeros()
@ -1372,6 +1395,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1405,13 +1429,15 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1570,6 +1596,7 @@ function psb_c_coo_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_maxval'
logical, parameter :: debug=.false.
@ -1594,6 +1621,7 @@ function psb_c_coo_csnmi(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csnmi'
logical, parameter :: debug=.false.
@ -1645,6 +1673,7 @@ function psb_c_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csnm1'
logical, parameter :: debug=.false.
@ -1677,7 +1706,8 @@ subroutine psb_c_coo_rowsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1686,10 +1716,8 @@ subroutine psb_c_coo_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1726,7 +1754,8 @@ subroutine psb_c_coo_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1735,10 +1764,8 @@ subroutine psb_c_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1775,7 +1802,8 @@ subroutine psb_c_coo_colsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1784,10 +1812,8 @@ subroutine psb_c_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1824,7 +1850,8 @@ subroutine psb_c_coo_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1833,10 +1860,8 @@ subroutine psb_c_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1899,6 +1924,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2178,6 +2204,7 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2456,36 +2483,37 @@ subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csput_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
info = psb_success_
call psb_erractionsave(err_act)
if (nz < 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2829,6 +2857,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2873,6 +2902,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2918,6 +2948,7 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2953,6 +2984,7 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2990,6 +3022,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3033,6 +3066,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3077,6 +3111,7 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3112,6 +3147,7 @@ subroutine psb_c_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3149,6 +3185,7 @@ subroutine psb_c_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3182,6 +3219,7 @@ subroutine psb_c_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3221,6 +3259,7 @@ subroutine psb_c_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3284,6 +3323,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_

157
base/serial/impl/psb_c_csc_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -305,6 +308,7 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_csmm'
logical, parameter :: debug=.false.
@ -333,14 +337,16 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -590,6 +596,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_cssv'
logical, parameter :: debug=.false.
@ -616,14 +623,16 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -810,6 +819,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:,:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@ -832,14 +842,16 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -867,7 +879,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
if (beta == czero) then
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
& a%icp,a%ia,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -881,7 +893,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
& a%icp,a%ia,a%val,tmp,size(tmp,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1033,6 +1045,7 @@ function psb_c_csc_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_maxval'
logical, parameter :: debug=.false.
@ -1056,6 +1069,7 @@ function psb_c_csc_csnmi(a) result(res)
real(psb_spk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csnmi'
logical, parameter :: debug=.false.
@ -1095,6 +1109,7 @@ function psb_c_csc_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_csnm1'
logical, parameter :: debug=.false.
@ -1125,7 +1140,8 @@ subroutine psb_c_csc_colsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1134,10 +1150,8 @@ subroutine psb_c_csc_colsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1174,7 +1188,8 @@ subroutine psb_c_csc_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1183,10 +1198,8 @@ subroutine psb_c_csc_aclsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1223,7 +1236,8 @@ subroutine psb_c_csc_rowsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1233,10 +1247,8 @@ subroutine psb_c_csc_rowsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1275,7 +1287,8 @@ subroutine psb_c_csc_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1285,10 +1298,8 @@ subroutine psb_c_csc_arwsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1327,6 +1338,7 @@ subroutine psb_c_csc_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1336,7 +1348,8 @@ subroutine psb_c_csc_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,6 +1394,7 @@ subroutine psb_c_csc_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1390,7 +1404,8 @@ subroutine psb_c_csc_scal(d,a,info)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1424,6 +1439,7 @@ subroutine psb_c_csc_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1483,6 +1499,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1614,8 +1631,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1630,8 +1647,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1672,6 +1689,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1806,9 +1824,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1824,9 +1842,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1857,36 +1875,37 @@ subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
info = psb_success_
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2274,7 +2293,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info)
debug_level = psb_get_debug_level()
call b%fix(info, idir=1)
call b%fix(info, idir=ione)
if (info /= psb_success_) return
nr = b%get_nrows()
@ -2509,6 +2528,7 @@ subroutine psb_c_csc_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -2539,6 +2559,7 @@ subroutine psb_c_csc_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_c_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_reallocate_nz'
logical, parameter :: debug=.false.
@ -2585,6 +2606,7 @@ subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2636,6 +2658,7 @@ subroutine psb_c_csc_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2683,6 +2706,7 @@ subroutine psb_c_csc_trim(a)
implicit none
class(psb_c_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2718,6 +2742,7 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz)
class(psb_c_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -2725,12 +2750,14 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -2740,7 +2767,8 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -2783,6 +2811,7 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_print'
logical, parameter :: debug=.false.
@ -2856,6 +2885,7 @@ subroutine psb_c_csc_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -2895,6 +2925,7 @@ subroutine psb_c_csc_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

129
base/serial/impl/psb_c_csr_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -374,6 +377,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_csmm'
logical, parameter :: debug=.false.
@ -403,14 +407,16 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -424,8 +430,8 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
call psb_c_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,ctra,acc)
& a%is_triangle(),a%is_unit(),x,size(x,1,kind=psb_ipk_), &
& beta,y,size(y,1,kind=psb_ipk_),tra,ctra,acc)
call psb_erractionrestore(err_act)
@ -724,6 +730,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:)
logical :: tra,ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_cssv'
logical, parameter :: debug=.false.
@ -751,14 +758,16 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -989,6 +998,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_cssm'
logical, parameter :: debug=.false.
@ -1035,7 +1045,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans)
if (beta == czero) then
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -1048,7 +1058,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1244,6 +1254,7 @@ function psb_c_csr_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_maxval'
logical, parameter :: debug=.false.
@ -1267,6 +1278,7 @@ function psb_c_csr_csnmi(a) result(res)
real(psb_spk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csnmi'
logical, parameter :: debug=.false.
@ -1297,6 +1309,7 @@ function psb_c_csr_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csnm1'
logical, parameter :: debug=.false.
@ -1332,7 +1345,8 @@ subroutine psb_c_csr_rowsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1341,10 +1355,8 @@ subroutine psb_c_csr_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,7 +1393,8 @@ subroutine psb_c_csr_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1390,10 +1403,8 @@ subroutine psb_c_csr_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1430,7 +1441,8 @@ subroutine psb_c_csr_colsum(d,a)
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1440,10 +1452,8 @@ subroutine psb_c_csr_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1482,7 +1492,8 @@ subroutine psb_c_csr_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1492,10 +1503,8 @@ subroutine psb_c_csr_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1533,6 +1542,7 @@ subroutine psb_c_csr_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1542,7 +1552,8 @@ subroutine psb_c_csr_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1588,6 +1599,7 @@ subroutine psb_c_csr_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1597,7 +1609,8 @@ subroutine psb_c_csr_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1631,6 +1644,7 @@ subroutine psb_c_csr_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1679,6 +1693,7 @@ subroutine psb_c_csr_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_c_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_reallocate_nz'
logical, parameter :: debug=.false.
@ -1715,6 +1730,7 @@ subroutine psb_c_csr_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -1745,6 +1761,7 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz)
class(psb_c_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -1752,12 +1769,14 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -1767,7 +1786,8 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -1821,6 +1841,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1997,6 +2018,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2171,6 +2193,7 @@ subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2229,9 +2252,10 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
@ -2239,27 +2263,27 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2511,6 +2535,7 @@ subroutine psb_c_csr_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2558,6 +2583,7 @@ subroutine psb_c_csr_trim(a)
implicit none
class(psb_c_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2597,6 +2623,7 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
@ -3035,6 +3062,7 @@ subroutine psb_c_csr_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3074,6 +3102,7 @@ subroutine psb_c_csr_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

110
base/serial/impl/psb_d_base_mat_impl.f90
Unescape Escape View File

@ -20,6 +20,7 @@ subroutine psb_d_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -47,6 +48,7 @@ subroutine psb_d_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -75,6 +77,7 @@ subroutine psb_d_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -100,6 +103,7 @@ subroutine psb_d_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -126,6 +130,7 @@ subroutine psb_d_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -153,6 +158,7 @@ subroutine psb_d_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -181,6 +187,7 @@ subroutine psb_d_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -206,6 +213,7 @@ subroutine psb_d_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -232,6 +240,7 @@ subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -268,6 +277,7 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -309,6 +319,7 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -367,6 +378,7 @@ subroutine psb_d_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -448,6 +460,7 @@ subroutine psb_d_base_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -475,6 +488,7 @@ subroutine psb_d_base_transp_2mat(a,b)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transp'
call psb_erractionsave(err_act)
@ -489,7 +503,8 @@ subroutine psb_d_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -513,6 +528,7 @@ subroutine psb_d_base_transc_2mat(a,b)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transc'
call psb_erractionsave(err_act)
@ -527,7 +543,8 @@ subroutine psb_d_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -550,6 +567,7 @@ subroutine psb_d_base_transp_1mat(a)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transp'
call psb_erractionsave(err_act)
@ -583,6 +601,7 @@ subroutine psb_d_base_transc_1mat(a)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transc'
call psb_erractionsave(err_act)
@ -634,6 +653,7 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@ -663,6 +683,7 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmv'
logical, parameter :: debug=.false.
@ -693,6 +714,7 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_cssm'
logical, parameter :: debug=.false.
@ -722,6 +744,7 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_cssv'
logical, parameter :: debug=.false.
@ -755,6 +778,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_dpk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -770,13 +794,15 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -795,8 +821,9 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -818,8 +845,9 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -843,7 +871,8 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -890,6 +919,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_dpk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -905,13 +935,15 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -930,8 +962,9 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -948,8 +981,9 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -973,7 +1007,8 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1038,6 +1073,7 @@ subroutine psb_d_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_scals'
logical, parameter :: debug=.false.
@ -1066,6 +1102,7 @@ subroutine psb_d_base_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_scal'
logical, parameter :: debug=.false.
@ -1095,6 +1132,7 @@ function psb_d_base_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1124,6 +1162,7 @@ function psb_d_base_csnmi(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
@ -1153,6 +1192,7 @@ function psb_d_base_csnm1(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
logical, parameter :: debug=.false.
@ -1180,6 +1220,7 @@ subroutine psb_d_base_rowsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1206,6 +1247,7 @@ subroutine psb_d_base_arwsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1232,6 +1274,7 @@ subroutine psb_d_base_colsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1258,6 +1301,7 @@ subroutine psb_d_base_aclsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1288,6 +1332,7 @@ subroutine psb_d_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1359,6 +1404,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_d_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -1374,13 +1420,15 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (x%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (y%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1402,8 +1450,9 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1422,8 +1471,9 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1450,7 +1500,8 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1494,6 +1545,7 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_vect_sv'
logical, parameter :: debug=.false.

146
base/serial/impl/psb_d_coo_impl.f90
Unescape Escape View File

@ -9,6 +9,7 @@ subroutine psb_d_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -18,7 +19,8 @@ subroutine psb_d_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
d(:) = dzero
@ -57,6 +59,7 @@ subroutine psb_d_coo_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -66,7 +69,8 @@ subroutine psb_d_coo_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -99,6 +103,7 @@ subroutine psb_d_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -132,6 +137,7 @@ subroutine psb_d_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -166,6 +172,7 @@ subroutine psb_d_coo_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -197,6 +204,7 @@ subroutine psb_d_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -246,6 +254,7 @@ subroutine psb_d_coo_trim(a)
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -281,6 +290,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -288,12 +298,14 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -303,7 +315,8 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -312,7 +325,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
if (info == psb_success_) then
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_nzeros(0)
call a%set_nzeros(izero)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_unit(.false.)
@ -347,6 +360,7 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_print'
logical, parameter :: debug=.false.
@ -471,6 +485,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@ -499,13 +514,15 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -528,7 +545,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
if (beta == dzero) then
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
& x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -542,7 +559,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
& x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -829,6 +846,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -851,13 +869,15 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1175,6 +1195,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1207,13 +1228,15 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
nnz = a%get_nzeros()
@ -1372,6 +1395,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1405,13 +1429,15 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1570,6 +1596,7 @@ function psb_d_coo_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_maxval'
logical, parameter :: debug=.false.
@ -1594,6 +1621,7 @@ function psb_d_coo_csnmi(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csnmi'
logical, parameter :: debug=.false.
@ -1645,6 +1673,7 @@ function psb_d_coo_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csnm1'
logical, parameter :: debug=.false.
@ -1677,7 +1706,8 @@ subroutine psb_d_coo_rowsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1686,10 +1716,8 @@ subroutine psb_d_coo_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1726,7 +1754,8 @@ subroutine psb_d_coo_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1735,10 +1764,8 @@ subroutine psb_d_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1775,7 +1802,8 @@ subroutine psb_d_coo_colsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1784,10 +1812,8 @@ subroutine psb_d_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1824,7 +1850,8 @@ subroutine psb_d_coo_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1833,10 +1860,8 @@ subroutine psb_d_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1899,6 +1924,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2178,6 +2204,7 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2456,36 +2483,37 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csput_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
info = psb_success_
call psb_erractionsave(err_act)
if (nz < 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2829,6 +2857,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2873,6 +2902,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2918,6 +2948,7 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2953,6 +2984,7 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2990,6 +3022,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3033,6 +3066,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3077,6 +3111,7 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3112,6 +3147,7 @@ subroutine psb_d_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3149,6 +3185,7 @@ subroutine psb_d_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3182,6 +3219,7 @@ subroutine psb_d_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3221,6 +3259,7 @@ subroutine psb_d_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3284,6 +3323,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_

157
base/serial/impl/psb_d_csc_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans)
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -305,6 +308,7 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_csmm'
logical, parameter :: debug=.false.
@ -333,14 +337,16 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -590,6 +596,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_cssv'
logical, parameter :: debug=.false.
@ -616,14 +623,16 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -810,6 +819,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@ -832,14 +842,16 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -867,7 +879,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans)
if (beta == dzero) then
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
& a%icp,a%ia,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -881,7 +893,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans)
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
& a%icp,a%ia,a%val,tmp,size(tmp,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1033,6 +1045,7 @@ function psb_d_csc_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_maxval'
logical, parameter :: debug=.false.
@ -1056,6 +1069,7 @@ function psb_d_csc_csnmi(a) result(res)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csnmi'
logical, parameter :: debug=.false.
@ -1095,6 +1109,7 @@ function psb_d_csc_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_csnm1'
logical, parameter :: debug=.false.
@ -1125,7 +1140,8 @@ subroutine psb_d_csc_colsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1134,10 +1150,8 @@ subroutine psb_d_csc_colsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1174,7 +1188,8 @@ subroutine psb_d_csc_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1183,10 +1198,8 @@ subroutine psb_d_csc_aclsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1223,7 +1236,8 @@ subroutine psb_d_csc_rowsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1233,10 +1247,8 @@ subroutine psb_d_csc_rowsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1275,7 +1287,8 @@ subroutine psb_d_csc_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1285,10 +1298,8 @@ subroutine psb_d_csc_arwsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1327,6 +1338,7 @@ subroutine psb_d_csc_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1336,7 +1348,8 @@ subroutine psb_d_csc_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,6 +1394,7 @@ subroutine psb_d_csc_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1390,7 +1404,8 @@ subroutine psb_d_csc_scal(d,a,info)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1424,6 +1439,7 @@ subroutine psb_d_csc_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1483,6 +1499,7 @@ subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1614,8 +1631,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1630,8 +1647,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1672,6 +1689,7 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1806,9 +1824,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1824,9 +1842,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1857,36 +1875,37 @@ subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
info = psb_success_
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2274,7 +2293,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
debug_level = psb_get_debug_level()
call b%fix(info, idir=1)
call b%fix(info, idir=ione)
if (info /= psb_success_) return
nr = b%get_nrows()
@ -2509,6 +2528,7 @@ subroutine psb_d_csc_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -2539,6 +2559,7 @@ subroutine psb_d_csc_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_d_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_reallocate_nz'
logical, parameter :: debug=.false.
@ -2585,6 +2606,7 @@ subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2636,6 +2658,7 @@ subroutine psb_d_csc_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2683,6 +2706,7 @@ subroutine psb_d_csc_trim(a)
implicit none
class(psb_d_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2718,6 +2742,7 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz)
class(psb_d_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -2725,12 +2750,14 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -2740,7 +2767,8 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -2783,6 +2811,7 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_print'
logical, parameter :: debug=.false.
@ -2856,6 +2885,7 @@ subroutine psb_d_csc_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -2895,6 +2925,7 @@ subroutine psb_d_csc_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

129
base/serial/impl/psb_d_csr_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -374,6 +377,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csmm'
logical, parameter :: debug=.false.
@ -403,14 +407,16 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -424,8 +430,8 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
call psb_d_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,ctra,acc)
& a%is_triangle(),a%is_unit(),x,size(x,1,kind=psb_ipk_), &
& beta,y,size(y,1,kind=psb_ipk_),tra,ctra,acc)
call psb_erractionrestore(err_act)
@ -724,6 +730,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra,ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_cssv'
logical, parameter :: debug=.false.
@ -751,14 +758,16 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -989,6 +998,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_cssm'
logical, parameter :: debug=.false.
@ -1035,7 +1045,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
if (beta == dzero) then
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -1048,7 +1058,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1244,6 +1254,7 @@ function psb_d_csr_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_maxval'
logical, parameter :: debug=.false.
@ -1267,6 +1278,7 @@ function psb_d_csr_csnmi(a) result(res)
real(psb_dpk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csnmi'
logical, parameter :: debug=.false.
@ -1297,6 +1309,7 @@ function psb_d_csr_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csnm1'
logical, parameter :: debug=.false.
@ -1332,7 +1345,8 @@ subroutine psb_d_csr_rowsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1341,10 +1355,8 @@ subroutine psb_d_csr_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,7 +1393,8 @@ subroutine psb_d_csr_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1390,10 +1403,8 @@ subroutine psb_d_csr_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1430,7 +1441,8 @@ subroutine psb_d_csr_colsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1440,10 +1452,8 @@ subroutine psb_d_csr_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1482,7 +1492,8 @@ subroutine psb_d_csr_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1492,10 +1503,8 @@ subroutine psb_d_csr_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1533,6 +1542,7 @@ subroutine psb_d_csr_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1542,7 +1552,8 @@ subroutine psb_d_csr_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1588,6 +1599,7 @@ subroutine psb_d_csr_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1597,7 +1609,8 @@ subroutine psb_d_csr_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1631,6 +1644,7 @@ subroutine psb_d_csr_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1679,6 +1693,7 @@ subroutine psb_d_csr_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_d_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_reallocate_nz'
logical, parameter :: debug=.false.
@ -1715,6 +1730,7 @@ subroutine psb_d_csr_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -1745,6 +1761,7 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
class(psb_d_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -1752,12 +1769,14 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -1767,7 +1786,8 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -1821,6 +1841,7 @@ subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1997,6 +2018,7 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2171,6 +2193,7 @@ subroutine psb_d_csr_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2229,9 +2252,10 @@ subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
@ -2239,27 +2263,27 @@ subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2511,6 +2535,7 @@ subroutine psb_d_csr_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2558,6 +2583,7 @@ subroutine psb_d_csr_trim(a)
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2597,6 +2623,7 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
@ -3035,6 +3062,7 @@ subroutine psb_d_csr_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3074,6 +3102,7 @@ subroutine psb_d_csr_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

110
base/serial/impl/psb_s_base_mat_impl.f90
Unescape Escape View File

@ -20,6 +20,7 @@ subroutine psb_s_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -47,6 +48,7 @@ subroutine psb_s_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -75,6 +77,7 @@ subroutine psb_s_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -100,6 +103,7 @@ subroutine psb_s_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -126,6 +130,7 @@ subroutine psb_s_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -153,6 +158,7 @@ subroutine psb_s_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -181,6 +187,7 @@ subroutine psb_s_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -206,6 +213,7 @@ subroutine psb_s_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -232,6 +240,7 @@ subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -268,6 +277,7 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -309,6 +319,7 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -367,6 +378,7 @@ subroutine psb_s_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -448,6 +460,7 @@ subroutine psb_s_base_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -475,6 +488,7 @@ subroutine psb_s_base_transp_2mat(a,b)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transp'
call psb_erractionsave(err_act)
@ -489,7 +503,8 @@ subroutine psb_s_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -513,6 +528,7 @@ subroutine psb_s_base_transc_2mat(a,b)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transc'
call psb_erractionsave(err_act)
@ -527,7 +543,8 @@ subroutine psb_s_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -550,6 +567,7 @@ subroutine psb_s_base_transp_1mat(a)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transp'
call psb_erractionsave(err_act)
@ -583,6 +601,7 @@ subroutine psb_s_base_transc_1mat(a)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transc'
call psb_erractionsave(err_act)
@ -634,6 +653,7 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@ -663,6 +683,7 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmv'
logical, parameter :: debug=.false.
@ -693,6 +714,7 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_cssm'
logical, parameter :: debug=.false.
@ -722,6 +744,7 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_cssv'
logical, parameter :: debug=.false.
@ -755,6 +778,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_spk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -770,13 +794,15 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -795,8 +821,9 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -818,8 +845,9 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -843,7 +871,8 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -890,6 +919,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_spk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -905,13 +935,15 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -930,8 +962,9 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -948,8 +981,9 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -973,7 +1007,8 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1038,6 +1073,7 @@ subroutine psb_s_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_scals'
logical, parameter :: debug=.false.
@ -1066,6 +1102,7 @@ subroutine psb_s_base_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_scal'
logical, parameter :: debug=.false.
@ -1095,6 +1132,7 @@ function psb_s_base_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1124,6 +1162,7 @@ function psb_s_base_csnmi(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
@ -1153,6 +1192,7 @@ function psb_s_base_csnm1(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
logical, parameter :: debug=.false.
@ -1180,6 +1220,7 @@ subroutine psb_s_base_rowsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1206,6 +1247,7 @@ subroutine psb_s_base_arwsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1232,6 +1274,7 @@ subroutine psb_s_base_colsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1258,6 +1301,7 @@ subroutine psb_s_base_aclsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1288,6 +1332,7 @@ subroutine psb_s_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1359,6 +1404,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_s_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -1374,13 +1420,15 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (x%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (y%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1402,8 +1450,9 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1422,8 +1471,9 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1450,7 +1500,8 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1494,6 +1545,7 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_vect_sv'
logical, parameter :: debug=.false.

146
base/serial/impl/psb_s_coo_impl.f90
Unescape Escape View File

@ -9,6 +9,7 @@ subroutine psb_s_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -18,7 +19,8 @@ subroutine psb_s_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
d(:) = szero
@ -57,6 +59,7 @@ subroutine psb_s_coo_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -66,7 +69,8 @@ subroutine psb_s_coo_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -99,6 +103,7 @@ subroutine psb_s_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -132,6 +137,7 @@ subroutine psb_s_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -166,6 +172,7 @@ subroutine psb_s_coo_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -197,6 +204,7 @@ subroutine psb_s_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -246,6 +254,7 @@ subroutine psb_s_coo_trim(a)
implicit none
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -281,6 +290,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -288,12 +298,14 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -303,7 +315,8 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -312,7 +325,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
if (info == psb_success_) then
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_nzeros(0)
call a%set_nzeros(izero)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_unit(.false.)
@ -347,6 +360,7 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_print'
logical, parameter :: debug=.false.
@ -471,6 +485,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@ -499,13 +514,15 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -528,7 +545,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
if (beta == szero) then
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
& x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -542,7 +559,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
& x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -829,6 +846,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -851,13 +869,15 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1175,6 +1195,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
real(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1207,13 +1228,15 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
nnz = a%get_nzeros()
@ -1372,6 +1395,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1405,13 +1429,15 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1570,6 +1596,7 @@ function psb_s_coo_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_maxval'
logical, parameter :: debug=.false.
@ -1594,6 +1621,7 @@ function psb_s_coo_csnmi(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csnmi'
logical, parameter :: debug=.false.
@ -1645,6 +1673,7 @@ function psb_s_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csnm1'
logical, parameter :: debug=.false.
@ -1677,7 +1706,8 @@ subroutine psb_s_coo_rowsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1686,10 +1716,8 @@ subroutine psb_s_coo_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1726,7 +1754,8 @@ subroutine psb_s_coo_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1735,10 +1764,8 @@ subroutine psb_s_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1775,7 +1802,8 @@ subroutine psb_s_coo_colsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1784,10 +1812,8 @@ subroutine psb_s_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1824,7 +1850,8 @@ subroutine psb_s_coo_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1833,10 +1860,8 @@ subroutine psb_s_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1899,6 +1924,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2178,6 +2204,7 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2456,36 +2483,37 @@ subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csput_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
info = psb_success_
call psb_erractionsave(err_act)
if (nz < 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2829,6 +2857,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2873,6 +2902,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2918,6 +2948,7 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2953,6 +2984,7 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2990,6 +3022,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3033,6 +3066,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3077,6 +3111,7 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3112,6 +3147,7 @@ subroutine psb_s_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3149,6 +3185,7 @@ subroutine psb_s_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3182,6 +3219,7 @@ subroutine psb_s_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3221,6 +3259,7 @@ subroutine psb_s_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3284,6 +3323,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_

157
base/serial/impl/psb_s_csc_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans)
real(psb_spk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans)
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -305,6 +308,7 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_csmm'
logical, parameter :: debug=.false.
@ -333,14 +337,16 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -590,6 +596,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_cssv'
logical, parameter :: debug=.false.
@ -616,14 +623,16 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -810,6 +819,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@ -832,14 +842,16 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -867,7 +879,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans)
if (beta == szero) then
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
& a%icp,a%ia,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -881,7 +893,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans)
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
& a%icp,a%ia,a%val,tmp,size(tmp,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1033,6 +1045,7 @@ function psb_s_csc_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_maxval'
logical, parameter :: debug=.false.
@ -1056,6 +1069,7 @@ function psb_s_csc_csnmi(a) result(res)
real(psb_spk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csnmi'
logical, parameter :: debug=.false.
@ -1095,6 +1109,7 @@ function psb_s_csc_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_csnm1'
logical, parameter :: debug=.false.
@ -1125,7 +1140,8 @@ subroutine psb_s_csc_colsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1134,10 +1150,8 @@ subroutine psb_s_csc_colsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1174,7 +1188,8 @@ subroutine psb_s_csc_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1183,10 +1198,8 @@ subroutine psb_s_csc_aclsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1223,7 +1236,8 @@ subroutine psb_s_csc_rowsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1233,10 +1247,8 @@ subroutine psb_s_csc_rowsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1275,7 +1287,8 @@ subroutine psb_s_csc_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1285,10 +1298,8 @@ subroutine psb_s_csc_arwsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1327,6 +1338,7 @@ subroutine psb_s_csc_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1336,7 +1348,8 @@ subroutine psb_s_csc_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,6 +1394,7 @@ subroutine psb_s_csc_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1390,7 +1404,8 @@ subroutine psb_s_csc_scal(d,a,info)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1424,6 +1439,7 @@ subroutine psb_s_csc_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1483,6 +1499,7 @@ subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1614,8 +1631,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1630,8 +1647,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1672,6 +1689,7 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1806,9 +1824,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1824,9 +1842,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1857,36 +1875,37 @@ subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
info = psb_success_
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2274,7 +2293,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info)
debug_level = psb_get_debug_level()
call b%fix(info, idir=1)
call b%fix(info, idir=ione)
if (info /= psb_success_) return
nr = b%get_nrows()
@ -2509,6 +2528,7 @@ subroutine psb_s_csc_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -2539,6 +2559,7 @@ subroutine psb_s_csc_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_s_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_reallocate_nz'
logical, parameter :: debug=.false.
@ -2585,6 +2606,7 @@ subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2636,6 +2658,7 @@ subroutine psb_s_csc_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2683,6 +2706,7 @@ subroutine psb_s_csc_trim(a)
implicit none
class(psb_s_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2718,6 +2742,7 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz)
class(psb_s_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -2725,12 +2750,14 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -2740,7 +2767,8 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -2783,6 +2811,7 @@ subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_print'
logical, parameter :: debug=.false.
@ -2856,6 +2885,7 @@ subroutine psb_s_csc_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -2895,6 +2925,7 @@ subroutine psb_s_csc_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

129
base/serial/impl/psb_s_csr_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
real(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -374,6 +377,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_csmm'
logical, parameter :: debug=.false.
@ -403,14 +407,16 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -424,8 +430,8 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
call psb_s_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,ctra,acc)
& a%is_triangle(),a%is_unit(),x,size(x,1,kind=psb_ipk_), &
& beta,y,size(y,1,kind=psb_ipk_),tra,ctra,acc)
call psb_erractionrestore(err_act)
@ -724,6 +730,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:)
logical :: tra,ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_cssv'
logical, parameter :: debug=.false.
@ -751,14 +758,16 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -989,6 +998,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_cssm'
logical, parameter :: debug=.false.
@ -1035,7 +1045,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
if (beta == szero) then
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -1048,7 +1058,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1244,6 +1254,7 @@ function psb_s_csr_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_maxval'
logical, parameter :: debug=.false.
@ -1267,6 +1278,7 @@ function psb_s_csr_csnmi(a) result(res)
real(psb_spk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csnmi'
logical, parameter :: debug=.false.
@ -1297,6 +1309,7 @@ function psb_s_csr_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csnm1'
logical, parameter :: debug=.false.
@ -1332,7 +1345,8 @@ subroutine psb_s_csr_rowsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1341,10 +1355,8 @@ subroutine psb_s_csr_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,7 +1393,8 @@ subroutine psb_s_csr_arwsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1390,10 +1403,8 @@ subroutine psb_s_csr_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1430,7 +1441,8 @@ subroutine psb_s_csr_colsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1440,10 +1452,8 @@ subroutine psb_s_csr_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1482,7 +1492,8 @@ subroutine psb_s_csr_aclsum(d,a)
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1492,10 +1503,8 @@ subroutine psb_s_csr_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1533,6 +1542,7 @@ subroutine psb_s_csr_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1542,7 +1552,8 @@ subroutine psb_s_csr_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1588,6 +1599,7 @@ subroutine psb_s_csr_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1597,7 +1609,8 @@ subroutine psb_s_csr_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1631,6 +1644,7 @@ subroutine psb_s_csr_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1679,6 +1693,7 @@ subroutine psb_s_csr_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_s_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_reallocate_nz'
logical, parameter :: debug=.false.
@ -1715,6 +1730,7 @@ subroutine psb_s_csr_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -1745,6 +1761,7 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz)
class(psb_s_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -1752,12 +1769,14 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -1767,7 +1786,8 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -1821,6 +1841,7 @@ subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1997,6 +2018,7 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2171,6 +2193,7 @@ subroutine psb_s_csr_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2229,9 +2252,10 @@ subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
@ -2239,27 +2263,27 @@ subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2511,6 +2535,7 @@ subroutine psb_s_csr_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2558,6 +2583,7 @@ subroutine psb_s_csr_trim(a)
implicit none
class(psb_s_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2597,6 +2623,7 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
@ -3035,6 +3062,7 @@ subroutine psb_s_csr_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3074,6 +3102,7 @@ subroutine psb_s_csr_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

110
base/serial/impl/psb_z_base_mat_impl.f90
Unescape Escape View File

@ -20,6 +20,7 @@ subroutine psb_z_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -47,6 +48,7 @@ subroutine psb_z_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -75,6 +77,7 @@ subroutine psb_z_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -100,6 +103,7 @@ subroutine psb_z_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -126,6 +130,7 @@ subroutine psb_z_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -153,6 +158,7 @@ subroutine psb_z_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -181,6 +187,7 @@ subroutine psb_z_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -206,6 +213,7 @@ subroutine psb_z_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -232,6 +240,7 @@ subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -268,6 +277,7 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -309,6 +319,7 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -367,6 +378,7 @@ subroutine psb_z_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -448,6 +460,7 @@ subroutine psb_z_base_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -475,6 +488,7 @@ subroutine psb_z_base_transp_2mat(a,b)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transp'
call psb_erractionsave(err_act)
@ -489,7 +503,8 @@ subroutine psb_z_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -513,6 +528,7 @@ subroutine psb_z_base_transc_2mat(a,b)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transc'
call psb_erractionsave(err_act)
@ -527,7 +543,8 @@ subroutine psb_z_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/))
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
goto 9999
end if
call psb_erractionrestore(err_act)
@ -550,6 +567,7 @@ subroutine psb_z_base_transp_1mat(a)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transp'
call psb_erractionsave(err_act)
@ -583,6 +601,7 @@ subroutine psb_z_base_transc_1mat(a)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transc'
call psb_erractionsave(err_act)
@ -634,6 +653,7 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@ -663,6 +683,7 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmv'
logical, parameter :: debug=.false.
@ -693,6 +714,7 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_cssm'
logical, parameter :: debug=.false.
@ -722,6 +744,7 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_cssv'
logical, parameter :: debug=.false.
@ -755,6 +778,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_dpk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -770,13 +794,15 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -795,8 +821,9 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -818,8 +845,9 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -843,7 +871,8 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -890,6 +919,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_dpk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -905,13 +935,15 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (size(x,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -930,8 +962,9 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -948,8 +981,9 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -973,7 +1007,8 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1038,6 +1073,7 @@ subroutine psb_z_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_scals'
logical, parameter :: debug=.false.
@ -1066,6 +1102,7 @@ subroutine psb_z_base_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_scal'
logical, parameter :: debug=.false.
@ -1095,6 +1132,7 @@ function psb_z_base_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1124,6 +1162,7 @@ function psb_z_base_csnmi(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
@ -1153,6 +1192,7 @@ function psb_z_base_csnm1(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
logical, parameter :: debug=.false.
@ -1180,6 +1220,7 @@ subroutine psb_z_base_rowsum(d,a)
complex(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1206,6 +1247,7 @@ subroutine psb_z_base_arwsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1232,6 +1274,7 @@ subroutine psb_z_base_colsum(d,a)
complex(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1258,6 +1301,7 @@ subroutine psb_z_base_aclsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1288,6 +1332,7 @@ subroutine psb_z_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1359,6 +1404,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_z_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -1374,13 +1420,15 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nac = a%get_ncols()
nc = 1
if (x%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/3,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (y%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/3,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1402,8 +1450,9 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = 36
call psb_errpush(info,name,i_err=(/9,nac,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1422,8 +1471,9 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = 36
call psb_errpush(info,name,i_err=(/9,nar,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1450,7 +1500,8 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_)
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
goto 9999
end if
else
@ -1494,6 +1545,7 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_vect_sv'
logical, parameter :: debug=.false.

146
base/serial/impl/psb_z_coo_impl.f90
Unescape Escape View File

@ -9,6 +9,7 @@ subroutine psb_z_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -18,7 +19,8 @@ subroutine psb_z_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
d(:) = zzero
@ -57,6 +59,7 @@ subroutine psb_z_coo_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -66,7 +69,8 @@ subroutine psb_z_coo_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -99,6 +103,7 @@ subroutine psb_z_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -132,6 +137,7 @@ subroutine psb_z_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -166,6 +172,7 @@ subroutine psb_z_coo_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -197,6 +204,7 @@ subroutine psb_z_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -246,6 +254,7 @@ subroutine psb_z_coo_trim(a)
implicit none
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -281,6 +290,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -288,12 +298,14 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -303,7 +315,8 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -312,7 +325,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
if (info == psb_success_) then
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_nzeros(0)
call a%set_nzeros(izero)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_unit(.false.)
@ -347,6 +360,7 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_print'
logical, parameter :: debug=.false.
@ -471,6 +485,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@ -499,13 +514,15 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -528,7 +545,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
if (beta == zzero) then
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
& x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -542,7 +559,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
& x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -829,6 +846,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -851,13 +869,15 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1175,6 +1195,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1207,13 +1228,15 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
nnz = a%get_nzeros()
@ -1372,6 +1395,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1405,13 +1429,15 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (size(x,1) < n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1570,6 +1596,7 @@ function psb_z_coo_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_maxval'
logical, parameter :: debug=.false.
@ -1594,6 +1621,7 @@ function psb_z_coo_csnmi(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csnmi'
logical, parameter :: debug=.false.
@ -1645,6 +1673,7 @@ function psb_z_coo_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csnm1'
logical, parameter :: debug=.false.
@ -1677,7 +1706,8 @@ subroutine psb_z_coo_rowsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1686,10 +1716,8 @@ subroutine psb_z_coo_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1726,7 +1754,8 @@ subroutine psb_z_coo_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1735,10 +1764,8 @@ subroutine psb_z_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1775,7 +1802,8 @@ subroutine psb_z_coo_colsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1784,10 +1812,8 @@ subroutine psb_z_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1824,7 +1850,8 @@ subroutine psb_z_coo_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1833,10 +1860,8 @@ subroutine psb_z_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1899,6 +1924,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2178,6 +2204,7 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2456,36 +2483,37 @@ subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csput_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
info = psb_success_
call psb_erractionsave(err_act)
if (nz < 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2829,6 +2857,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2873,6 +2902,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2918,6 +2948,7 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2953,6 +2984,7 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -2990,6 +3022,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3033,6 +3066,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3077,6 +3111,7 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3112,6 +3147,7 @@ subroutine psb_z_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3149,6 +3185,7 @@ subroutine psb_z_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3182,6 +3219,7 @@ subroutine psb_z_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3221,6 +3259,7 @@ subroutine psb_z_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3284,6 +3323,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_

157
base/serial/impl/psb_z_csc_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -305,6 +308,7 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_csmm'
logical, parameter :: debug=.false.
@ -333,14 +337,16 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -590,6 +596,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_cssv'
logical, parameter :: debug=.false.
@ -616,14 +623,16 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -810,6 +819,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@ -832,14 +842,16 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -867,7 +879,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
if (beta == zzero) then
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
& a%icp,a%ia,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -881,7 +893,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
& a%icp,a%ia,a%val,tmp,size(tmp,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1033,6 +1045,7 @@ function psb_z_csc_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_maxval'
logical, parameter :: debug=.false.
@ -1056,6 +1069,7 @@ function psb_z_csc_csnmi(a) result(res)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csnmi'
logical, parameter :: debug=.false.
@ -1095,6 +1109,7 @@ function psb_z_csc_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_csnm1'
logical, parameter :: debug=.false.
@ -1125,7 +1140,8 @@ subroutine psb_z_csc_colsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1134,10 +1150,8 @@ subroutine psb_z_csc_colsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1174,7 +1188,8 @@ subroutine psb_z_csc_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1183,10 +1198,8 @@ subroutine psb_z_csc_aclsum(d,a)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1223,7 +1236,8 @@ subroutine psb_z_csc_rowsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1233,10 +1247,8 @@ subroutine psb_z_csc_rowsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1275,7 +1287,8 @@ subroutine psb_z_csc_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1285,10 +1298,8 @@ subroutine psb_z_csc_arwsum(d,a)
n = a%get_nrows()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1327,6 +1338,7 @@ subroutine psb_z_csc_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1336,7 +1348,8 @@ subroutine psb_z_csc_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,6 +1394,7 @@ subroutine psb_z_csc_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1390,7 +1404,8 @@ subroutine psb_z_csc_scal(d,a,info)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1424,6 +1439,7 @@ subroutine psb_z_csc_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1483,6 +1499,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1614,8 +1631,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1630,8 +1647,8 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
@ -1672,6 +1689,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1806,9 +1824,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1824,9 +1842,9 @@ contains
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
call psb_ensure_size(int(1.25*nzin_)+1,val,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ia,info)
call psb_ensure_size(int(1.25*nzin_)+ione,ja,info)
call psb_ensure_size(int(1.25*nzin_)+ione,val,info)
isz = min(size(ia),size(ja),size(val))
end if
nz = nz + 1
@ -1857,36 +1875,37 @@ subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
info = psb_success_
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2274,7 +2293,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info)
debug_level = psb_get_debug_level()
call b%fix(info, idir=1)
call b%fix(info, idir=ione)
if (info /= psb_success_) return
nr = b%get_nrows()
@ -2509,6 +2528,7 @@ subroutine psb_z_csc_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -2539,6 +2559,7 @@ subroutine psb_z_csc_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_z_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_reallocate_nz'
logical, parameter :: debug=.false.
@ -2585,6 +2606,7 @@ subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2636,6 +2658,7 @@ subroutine psb_z_csc_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2683,6 +2706,7 @@ subroutine psb_z_csc_trim(a)
implicit none
class(psb_z_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, n
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2718,6 +2742,7 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz)
class(psb_z_csc_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -2725,12 +2750,14 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -2740,7 +2767,8 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -2783,6 +2811,7 @@ subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_print'
logical, parameter :: debug=.false.
@ -2856,6 +2885,7 @@ subroutine psb_z_csc_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -2895,6 +2925,7 @@ subroutine psb_z_csc_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

129
base/serial/impl/psb_z_csr_impl.f90
Unescape Escape View File

@ -28,6 +28,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_csmv'
logical, parameter :: debug=.false.
@ -59,14 +60,16 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -374,6 +377,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_csmm'
logical, parameter :: debug=.false.
@ -403,14 +407,16 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = n;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -424,8 +430,8 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans)
end if
call psb_z_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,ctra,acc)
& a%is_triangle(),a%is_unit(),x,size(x,1,kind=psb_ipk_), &
& beta,y,size(y,1,kind=psb_ipk_),tra,ctra,acc)
call psb_erractionrestore(err_act)
@ -724,6 +730,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:)
logical :: tra,ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_cssv'
logical, parameter :: debug=.false.
@ -751,14 +758,16 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans)
end if
if (size(x)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(y)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = m;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -989,6 +998,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_cssm'
logical, parameter :: debug=.false.
@ -1035,7 +1045,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans)
if (beta == zzero) then
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
end do
@ -1048,7 +1058,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
& a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
end do
@ -1244,6 +1254,7 @@ function psb_z_csr_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_maxval'
logical, parameter :: debug=.false.
@ -1267,6 +1278,7 @@ function psb_z_csr_csnmi(a) result(res)
real(psb_dpk_) :: acc
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csnmi'
logical, parameter :: debug=.false.
@ -1297,6 +1309,7 @@ function psb_z_csr_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csnm1'
logical, parameter :: debug=.false.
@ -1332,7 +1345,8 @@ subroutine psb_z_csr_rowsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1341,10 +1355,8 @@ subroutine psb_z_csr_rowsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1381,7 +1393,8 @@ subroutine psb_z_csr_arwsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1390,10 +1403,8 @@ subroutine psb_z_csr_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = m
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1430,7 +1441,8 @@ subroutine psb_z_csr_colsum(d,a)
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1440,10 +1452,8 @@ subroutine psb_z_csr_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1482,7 +1492,8 @@ subroutine psb_z_csr_aclsum(d,a)
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info, int_err(5)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1492,10 +1503,8 @@ subroutine psb_z_csr_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
int_err(1) = 1
int_err(2) = size(d)
int_err(3) = n
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1533,6 +1542,7 @@ subroutine psb_z_csr_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, mnm, i, j, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1542,7 +1552,8 @@ subroutine psb_z_csr_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1588,6 +1599,7 @@ subroutine psb_z_csr_scal(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1597,7 +1609,8 @@ subroutine psb_z_csr_scal(d,a,info)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -1631,6 +1644,7 @@ subroutine psb_z_csr_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -1679,6 +1693,7 @@ subroutine psb_z_csr_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_z_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_reallocate_nz'
logical, parameter :: debug=.false.
@ -1715,6 +1730,7 @@ subroutine psb_z_csr_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(out), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@ -1745,6 +1761,7 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz)
class(psb_z_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -1752,12 +1769,14 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
if (present(nz)) then
@ -1767,7 +1786,8 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
goto 9999
endif
@ -1821,6 +1841,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -1997,6 +2018,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2171,6 +2193,7 @@ subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
@ -2229,9 +2252,10 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_csput'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, int_err(5)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza
call psb_erractionsave(err_act)
@ -2239,27 +2263,27 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz <= 0) then
info = psb_err_iarg_neg_
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -2511,6 +2535,7 @@ subroutine psb_z_csr_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -2558,6 +2583,7 @@ subroutine psb_z_csr_trim(a)
implicit none
class(psb_z_csr_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -2597,6 +2623,7 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
@ -3035,6 +3062,7 @@ subroutine psb_z_csr_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3074,6 +3102,7 @@ subroutine psb_z_csr_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.

Write Preview
Loading…
Cancel
Save