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/psb_cnumbmm.f90
 base/serial/psb_csymbmm.f90
 base/serial/psb_dnumbmm.f90
 base/serial/psb_dsymbmm.f90
 base/serial/psb_snumbmm.f90
 base/serial/psb_sort_impl.f90
 base/serial/psb_ssymbmm.f90
 base/serial/psb_znumbmm.f90
 base/serial/psb_zsymbmm.f90
 base/serial/psi_serial_impl.f90


Next batch.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent a3931c2b6d
commit 9c153be7ff
10 changed files with 280 additions and 151 deletions
Show Stats Download Patch File Download Diff File

8
base/serial/psb_cnumbmm.f90
Unescape Escape View File

@ -122,7 +122,7 @@ subroutine psb_cbase_numbmm(a,b,c)
! Note: we still have to test about possible performance hits. ! Note: we still have to test about possible performance hits.
! !
! !
call psb_ensure_size(size(c%ja),c%val,info) call psb_ensure_size(ione*size(c%ja),c%val,info)
select type(a) select type(a)
type is (psb_c_csr_sparse_mat) type is (psb_c_csr_sparse_mat)
select type(b) select type(b)
@ -169,9 +169,9 @@ contains
mb = b%get_nrows() mb = b%get_nrows()
nb = b%get_ncols() nb = b%get_ncols()
call cnumbmm(ma,na,nb,a%irp,a%ja,0,a%val,& call cnumbmm(ma,na,nb,a%irp,a%ja,izero,a%val,&
& b%irp,b%ja,0,b%val,& & b%irp,b%ja,izero,b%val,&
& c%irp,c%ja,0,c%val,temp) & c%irp,c%ja,izero,c%val,temp)
end subroutine csr_numbmm end subroutine csr_numbmm

6
base/serial/psb_csymbmm.f90
Unescape Escape View File

@ -177,9 +177,9 @@ contains
nze = max(ma+1,2*ma) nze = max(ma+1,2*ma)
call c%allocate(ma,nb,nze) call c%allocate(ma,nb,nze)
call symbmm(ma,na,nb,a%irp,a%ja,0,& call symbmm(ma,na,nb,a%irp,a%ja,izero,&
& b%irp,b%ja,0,& & b%irp,b%ja,izero,&
& c%irp,c%ja,0,itemp) & c%irp,c%ja,izero,itemp)
end subroutine csr_symbmm end subroutine csr_symbmm
subroutine gen_symbmm(a,b,c,index,info) subroutine gen_symbmm(a,b,c,index,info)

8
base/serial/psb_dnumbmm.f90
Unescape Escape View File

@ -122,7 +122,7 @@ subroutine psb_dbase_numbmm(a,b,c)
! Note: we still have to test about possible performance hits. ! Note: we still have to test about possible performance hits.
! !
! !
call psb_ensure_size(size(c%ja),c%val,info) call psb_ensure_size(ione*size(c%ja),c%val,info)
select type(a) select type(a)
type is (psb_d_csr_sparse_mat) type is (psb_d_csr_sparse_mat)
select type(b) select type(b)
@ -169,9 +169,9 @@ contains
mb = b%get_nrows() mb = b%get_nrows()
nb = b%get_ncols() nb = b%get_ncols()
call dnumbmm(ma,na,nb,a%irp,a%ja,0,a%val,& call dnumbmm(ma,na,nb,a%irp,a%ja,izero,a%val,&
& b%irp,b%ja,0,b%val,& & b%irp,b%ja,izero,b%val,&
& c%irp,c%ja,0,c%val,temp) & c%irp,c%ja,izero,c%val,temp)
end subroutine csr_numbmm end subroutine csr_numbmm

6
base/serial/psb_dsymbmm.f90
Unescape Escape View File

@ -177,9 +177,9 @@ contains
nze = max(ma+1,2*ma) nze = max(ma+1,2*ma)
call c%allocate(ma,nb,nze) call c%allocate(ma,nb,nze)
call symbmm(ma,na,nb,a%irp,a%ja,0,& call symbmm(ma,na,nb,a%irp,a%ja,izero,&
& b%irp,b%ja,0,& & b%irp,b%ja,izero,&
& c%irp,c%ja,0,itemp) & c%irp,c%ja,izero,itemp)
end subroutine csr_symbmm end subroutine csr_symbmm
subroutine gen_symbmm(a,b,c,index,info) subroutine gen_symbmm(a,b,c,index,info)

8
base/serial/psb_snumbmm.f90
Unescape Escape View File

@ -122,7 +122,7 @@ subroutine psb_sbase_numbmm(a,b,c)
! Note: we still have to test about possible performance hits. ! Note: we still have to test about possible performance hits.
! !
! !
call psb_ensure_size(size(c%ja),c%val,info) call psb_ensure_size(ione*size(c%ja),c%val,info)
select type(a) select type(a)
type is (psb_s_csr_sparse_mat) type is (psb_s_csr_sparse_mat)
select type(b) select type(b)
@ -169,9 +169,9 @@ contains
mb = b%get_nrows() mb = b%get_nrows()
nb = b%get_ncols() nb = b%get_ncols()
call snumbmm(ma,na,nb,a%irp,a%ja,0,a%val,& call snumbmm(ma,na,nb,a%irp,a%ja,izero,a%val,&
& b%irp,b%ja,0,b%val,& & b%irp,b%ja,izero,b%val,&
& c%irp,c%ja,0,c%val,temp) & c%irp,c%ja,izero,c%val,temp)
end subroutine csr_numbmm end subroutine csr_numbmm

177
base/serial/psb_sort_impl.f90
Unescape Escape View File

@ -85,7 +85,7 @@ logical function psb_isaperm(n,eip)
ip(i) = -j ip(i) = -j
i = j i = j
enddo enddo
ip(m) = iabs(ip(m)) ip(m) = abs(ip(m))
if (j /= m) then if (j /= m) then
psb_isaperm = .false. psb_isaperm = .false.
goto 9999 goto 9999
@ -195,6 +195,7 @@ subroutine imsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort' name='psb_msort'
@ -209,7 +210,8 @@ subroutine imsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -217,7 +219,8 @@ subroutine imsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (present(flag)) then if (present(flag)) then
@ -229,7 +232,8 @@ subroutine imsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -256,6 +260,7 @@ subroutine smsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort' name='psb_msort'
@ -270,7 +275,8 @@ subroutine smsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -278,7 +284,8 @@ subroutine smsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (present(flag)) then if (present(flag)) then
@ -290,7 +297,8 @@ subroutine smsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -316,6 +324,7 @@ subroutine dmsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort' name='psb_msort'
@ -330,7 +339,8 @@ subroutine dmsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -338,7 +348,8 @@ subroutine dmsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (present(flag)) then if (present(flag)) then
@ -350,7 +361,8 @@ subroutine dmsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -376,6 +388,7 @@ subroutine camsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort' name='psb_msort'
@ -390,7 +403,8 @@ subroutine camsort(x,ix,dir,flag)
case( psb_asort_up_, psb_asort_down_) case( psb_asort_up_, psb_asort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -398,7 +412,8 @@ subroutine camsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (present(flag)) then if (present(flag)) then
@ -410,7 +425,8 @@ subroutine camsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -436,6 +452,7 @@ subroutine zamsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort' name='psb_msort'
@ -450,7 +467,8 @@ subroutine zamsort(x,ix,dir,flag)
case( psb_asort_up_, psb_asort_down_) case( psb_asort_up_, psb_asort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -458,7 +476,8 @@ subroutine zamsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (present(flag)) then if (present(flag)) then
@ -470,7 +489,8 @@ subroutine zamsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -497,6 +517,7 @@ subroutine imsort_u(x,nout,dir)
integer(psb_ipk_) :: dir_, n, err_act integer(psb_ipk_) :: dir_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_msort_u' name='psb_msort_u'
@ -511,7 +532,8 @@ subroutine imsort_u(x,nout,dir)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -538,6 +560,7 @@ subroutine iqsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_qsort' name='psb_qsort'
@ -552,7 +575,8 @@ subroutine iqsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -568,7 +592,8 @@ subroutine iqsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -581,7 +606,8 @@ subroutine iqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -591,7 +617,8 @@ subroutine iqsort(x,ix,dir,flag)
end if end if
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -615,6 +642,7 @@ subroutine sqsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_qsort' name='psb_qsort'
@ -629,7 +657,8 @@ subroutine sqsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -645,7 +674,8 @@ subroutine sqsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -658,7 +688,8 @@ subroutine sqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -668,7 +699,8 @@ subroutine sqsort(x,ix,dir,flag)
end if end if
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -691,6 +723,7 @@ subroutine dqsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_qsort' name='psb_qsort'
@ -705,7 +738,8 @@ subroutine dqsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -721,7 +755,8 @@ subroutine dqsort(x,ix,dir,flag)
case( psb_sort_up_, psb_sort_down_) case( psb_sort_up_, psb_sort_down_)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -734,7 +769,8 @@ subroutine dqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -744,7 +780,8 @@ subroutine dqsort(x,ix,dir,flag)
end if end if
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -768,6 +805,7 @@ subroutine cqsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_qsort' name='psb_qsort'
@ -782,7 +820,8 @@ subroutine cqsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -798,7 +837,8 @@ subroutine cqsort(x,ix,dir,flag)
case( psb_lsort_up_, psb_lsort_down_) case( psb_lsort_up_, psb_lsort_down_)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -811,7 +851,8 @@ subroutine cqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -824,7 +865,8 @@ subroutine cqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -834,7 +876,8 @@ subroutine cqsort(x,ix,dir,flag)
end if end if
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -858,6 +901,7 @@ subroutine zqsort(x,ix,dir,flag)
integer(psb_ipk_) :: dir_, flag_, n, err_act integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_qsort' name='psb_qsort'
@ -872,7 +916,8 @@ subroutine zqsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -888,7 +933,8 @@ subroutine zqsort(x,ix,dir,flag)
case( psb_lsort_up_, psb_lsort_down_) case( psb_lsort_up_, psb_lsort_down_)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -901,7 +947,8 @@ subroutine zqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -914,7 +961,8 @@ subroutine zqsort(x,ix,dir,flag)
! OK keep going ! OK keep going
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -924,7 +972,8 @@ subroutine zqsort(x,ix,dir,flag)
end if end if
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -952,6 +1001,7 @@ subroutine ihsort(x,ix,dir,flag)
integer(psb_ipk_) :: key integer(psb_ipk_) :: key
integer(psb_ipk_) :: index integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_hsort' name='psb_hsort'
@ -966,7 +1016,8 @@ subroutine ihsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -980,7 +1031,8 @@ subroutine ihsort(x,ix,dir,flag)
case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! OK ! OK
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -997,7 +1049,8 @@ subroutine ihsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (flag_ == psb_sort_ovw_idx_) then if (flag_ == psb_sort_ovw_idx_) then
@ -1061,6 +1114,7 @@ subroutine shsort(x,ix,dir,flag)
real(psb_spk_) :: key real(psb_spk_) :: key
integer(psb_ipk_) :: index integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_hsort' name='psb_hsort'
@ -1075,7 +1129,8 @@ subroutine shsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1089,7 +1144,8 @@ subroutine shsort(x,ix,dir,flag)
case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! OK ! OK
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1106,7 +1162,8 @@ subroutine shsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (flag_ == psb_sort_ovw_idx_) then if (flag_ == psb_sort_ovw_idx_) then
@ -1170,6 +1227,7 @@ subroutine dhsort(x,ix,dir,flag)
real(psb_dpk_) :: key real(psb_dpk_) :: key
integer(psb_ipk_) :: index integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_hsort' name='psb_hsort'
@ -1184,7 +1242,8 @@ subroutine dhsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1198,7 +1257,8 @@ subroutine dhsort(x,ix,dir,flag)
case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! OK ! OK
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1215,7 +1275,8 @@ subroutine dhsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (flag_ == psb_sort_ovw_idx_) then if (flag_ == psb_sort_ovw_idx_) then
@ -1279,6 +1340,7 @@ subroutine chsort(x,ix,dir,flag)
complex(psb_spk_) :: key complex(psb_spk_) :: key
integer(psb_ipk_) :: index integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_hsort' name='psb_hsort'
@ -1293,7 +1355,8 @@ subroutine chsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1307,7 +1370,8 @@ subroutine chsort(x,ix,dir,flag)
case(psb_asort_up_,psb_asort_down_) case(psb_asort_up_,psb_asort_down_)
! OK ! OK
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1324,7 +1388,8 @@ subroutine chsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (flag_ == psb_sort_ovw_idx_) then if (flag_ == psb_sort_ovw_idx_) then
@ -1388,6 +1453,7 @@ subroutine zhsort(x,ix,dir,flag)
complex(psb_dpk_) :: key complex(psb_dpk_) :: key
integer(psb_ipk_) :: index integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
name='psb_hsort' name='psb_hsort'
@ -1402,7 +1468,8 @@ subroutine zhsort(x,ix,dir,flag)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_) case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going ! OK keep going
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1416,7 +1483,8 @@ subroutine zhsort(x,ix,dir,flag)
case(psb_asort_up_,psb_asort_down_) case(psb_asort_up_,psb_asort_down_)
! OK ! OK
case default case default
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end select end select
@ -1433,7 +1501,8 @@ subroutine zhsort(x,ix,dir,flag)
if (present(ix)) then if (present(ix)) then
if (size(ix) < n) then if (size(ix) < n) then
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (flag_ == psb_sort_ovw_idx_) then if (flag_ == psb_sort_ovw_idx_) then

6
base/serial/psb_ssymbmm.f90
Unescape Escape View File

@ -177,9 +177,9 @@ contains
nze = max(ma+1,2*ma) nze = max(ma+1,2*ma)
call c%allocate(ma,nb,nze) call c%allocate(ma,nb,nze)
call symbmm(ma,na,nb,a%irp,a%ja,0,& call symbmm(ma,na,nb,a%irp,a%ja,izero,&
& b%irp,b%ja,0,& & b%irp,b%ja,izero,&
& c%irp,c%ja,0,itemp) & c%irp,c%ja,izero,itemp)
end subroutine csr_symbmm end subroutine csr_symbmm
subroutine gen_symbmm(a,b,c,index,info) subroutine gen_symbmm(a,b,c,index,info)

8
base/serial/psb_znumbmm.f90
Unescape Escape View File

@ -122,7 +122,7 @@ subroutine psb_zbase_numbmm(a,b,c)
! Note: we still have to test about possible performance hits. ! Note: we still have to test about possible performance hits.
! !
! !
call psb_ensure_size(size(c%ja),c%val,info) call psb_ensure_size(ione*size(c%ja),c%val,info)
select type(a) select type(a)
type is (psb_z_csr_sparse_mat) type is (psb_z_csr_sparse_mat)
select type(b) select type(b)
@ -169,9 +169,9 @@ contains
mb = b%get_nrows() mb = b%get_nrows()
nb = b%get_ncols() nb = b%get_ncols()
call znumbmm(ma,na,nb,a%irp,a%ja,0,a%val,& call znumbmm(ma,na,nb,a%irp,a%ja,izero,a%val,&
& b%irp,b%ja,0,b%val,& & b%irp,b%ja,izero,b%val,&
& c%irp,c%ja,0,c%val,temp) & c%irp,c%ja,izero,c%val,temp)
end subroutine csr_numbmm end subroutine csr_numbmm

6
base/serial/psb_zsymbmm.f90
Unescape Escape View File

@ -177,9 +177,9 @@ contains
nze = max(ma+1,2*ma) nze = max(ma+1,2*ma)
call c%allocate(ma,nb,nze) call c%allocate(ma,nb,nze)
call symbmm(ma,na,nb,a%irp,a%ja,0,& call symbmm(ma,na,nb,a%irp,a%ja,izero,&
& b%irp,b%ja,0,& & b%irp,b%ja,izero,&
& c%irp,c%ja,0,itemp) & c%irp,c%ja,izero,itemp)
end subroutine csr_symbmm end subroutine csr_symbmm
subroutine gen_symbmm(a,b,c,index,info) subroutine gen_symbmm(a,b,c,index,info)

198
base/serial/psi_serial_impl.f90
Unescape Escape View File

@ -856,6 +856,8 @@ subroutine psi_saxpbyv(m,alpha, x, beta, y, info)
real(psb_spk_), intent (in) :: alpha, beta real(psb_spk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -865,21 +867,26 @@ subroutine psi_saxpbyv(m,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) ierr(1) = 5; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (m>0) call saxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) if (m>0) call saxpby(m,ione,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -904,6 +911,8 @@ subroutine psi_saxpby(m,n,alpha, x, beta, y, info)
real(psb_spk_), intent (in) :: alpha, beta real(psb_spk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -913,27 +922,33 @@ subroutine psi_saxpby(m,n,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (n < 0) then if (n < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) ierr(1) = 2; ierr(2) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x,1) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 4; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y,1) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) ierr(1) = 6; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if ((m>0).and.(n>0)) call saxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) if ((m>0).and.(n>0)) &
& call saxpby(m,n,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -958,6 +973,8 @@ subroutine psi_daxpbyv(m,alpha, x, beta, y, info)
real(psb_dpk_), intent (in) :: alpha, beta real(psb_dpk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -967,21 +984,26 @@ subroutine psi_daxpbyv(m,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) ierr(1) = 5; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (m>0) call daxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) if (m>0) call daxpby(m,ione,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -1006,6 +1028,8 @@ subroutine psi_daxpby(m,n,alpha, x, beta, y, info)
real(psb_dpk_), intent (in) :: alpha, beta real(psb_dpk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -1015,26 +1039,32 @@ subroutine psi_daxpby(m,n,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (n < 0) then if (n < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) ierr(1) = 2; ierr(2) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x,1) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 4; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y,1) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) ierr(1) = 6; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -1059,6 +1089,8 @@ subroutine psi_caxpbyv(m,alpha, x, beta, y, info)
complex(psb_spk_), intent (in) :: alpha, beta complex(psb_spk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -1068,21 +1100,26 @@ subroutine psi_caxpbyv(m,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) ierr(1) = 5; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (m>0) call caxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) if (m>0) call caxpby(m,ione,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -1107,6 +1144,8 @@ subroutine psi_caxpby(m,n,alpha, x, beta, y, info)
complex(psb_spk_), intent (in) :: alpha, beta complex(psb_spk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -1116,26 +1155,32 @@ subroutine psi_caxpby(m,n,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (n < 0) then if (n < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) ierr(1) = 2; ierr(2) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x,1) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 4; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y,1) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) ierr(1) = 6; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -1160,6 +1205,8 @@ subroutine psi_zaxpbyv(m,alpha, x, beta, y, info)
complex(psb_dpk_), intent (in) :: alpha, beta complex(psb_dpk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -1169,21 +1216,26 @@ subroutine psi_zaxpbyv(m,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) ierr(1) = 5; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (m>0) call zaxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) if (m>0) call zaxpby(m,ione,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -1208,6 +1260,8 @@ subroutine psi_zaxpby(m,n,alpha, x, beta, y, info)
complex(psb_dpk_), intent (in) :: alpha, beta complex(psb_dpk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: lx, ly
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_geaxpby' name='psb_geaxpby'
@ -1217,26 +1271,32 @@ subroutine psi_zaxpby(m,n,alpha, x, beta, y, info)
if (m < 0) then if (m < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) ierr(1) = 1; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (n < 0) then if (n < 0) then
info = psb_err_iarg_neg_ info = psb_err_iarg_neg_
call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) ierr(1) = 2; ierr(2) = n
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(x,1) < m) then lx = size(x,1)
info = 36 ly = size(y,1)
call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) if (lx < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 4; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if (size(y,1) < m) then if (ly < m) then
info = 36 info = psb_err_input_asize_small_i_
call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) ierr(1) = 6; ierr(2) = m
call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,lx,beta,y,ly,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save