#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_lu_comp
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sgecon( norm, n, a, lda, anorm, rcond, work, iwork,info )
!! SGECON estimates the reciprocal of the condition number of a general
!! real matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by SGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, scale, sl, smlnum, su
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_slatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
! multiply by inv(u).
call stdlib${ii}$_slatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, work( 3_${ik}$*n+1 ), info )
else
! multiply by inv(u**t).
call stdlib${ii}$_slatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, su,&
work( 3_${ik}$*n+1 ), info )
! multiply by inv(l**t).
call stdlib${ii}$_slatrs( 'LOWER', 'TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_sgecon
pure module subroutine stdlib${ii}$_dgecon( norm, n, a, lda, anorm, rcond, work, iwork,info )
!! DGECON estimates the reciprocal of the condition number of a general
!! real matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by DGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, scale, sl, smlnum, su
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_dlatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
! multiply by inv(u).
call stdlib${ii}$_dlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, work( 3_${ik}$*n+1 ), info )
else
! multiply by inv(u**t).
call stdlib${ii}$_dlatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, su,&
work( 3_${ik}$*n+1 ), info )
! multiply by inv(l**t).
call stdlib${ii}$_dlatrs( 'LOWER', 'TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_dgecon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gecon( norm, n, a, lda, anorm, rcond, work, iwork,info )
!! DGECON: estimates the reciprocal of the condition number of a general
!! real matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by DGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${rk}$) :: ainvnm, scale, sl, smlnum, su
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_${ri}$latrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
! multiply by inv(u).
call stdlib${ii}$_${ri}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, work( 3_${ik}$*n+1 ), info )
else
! multiply by inv(u**t).
call stdlib${ii}$_${ri}$latrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, su,&
work( 3_${ik}$*n+1 ), info )
! multiply by inv(l**t).
call stdlib${ii}$_${ri}$latrs( 'LOWER', 'TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
work( 2_${ik}$*n+1 ), info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ri}$gecon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgecon( norm, n, a, lda, anorm, rcond, work, rwork,info )
!! CGECON estimates the reciprocal of the condition number of a general
!! complex matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by CGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, scale, sl, smlnum, su
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_clatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
rwork, info )
! multiply by inv(u).
call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, rwork( n+1 ), info )
else
! multiply by inv(u**h).
call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, su, rwork( n+1 ),info )
! multiply by inv(l**h).
call stdlib${ii}$_clatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT', normin,n, a, lda, &
work, sl, rwork, info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_cgecon
pure module subroutine stdlib${ii}$_zgecon( norm, n, a, lda, anorm, rcond, work, rwork,info )
!! ZGECON estimates the reciprocal of the condition number of a general
!! complex matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by ZGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, scale, sl, smlnum, su
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_zlatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
rwork, info )
! multiply by inv(u).
call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, rwork( n+1 ), info )
else
! multiply by inv(u**h).
call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, su, rwork( n+1 ),info )
! multiply by inv(l**h).
call stdlib${ii}$_zlatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT', normin,n, a, lda, &
work, sl, rwork, info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_zgecon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gecon( norm, n, a, lda, anorm, rcond, work, rwork,info )
!! ZGECON: estimates the reciprocal of the condition number of a general
!! complex matrix A, in either the 1-norm or the infinity-norm, using
!! the LU factorization computed by ZGETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${ck}$) :: ainvnm, scale, sl, smlnum, su
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
call stdlib${ii}$_${ci}$latrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, &
rwork, info )
! multiply by inv(u).
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
su, rwork( n+1 ), info )
else
! multiply by inv(u**h).
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, su, rwork( n+1 ),info )
! multiply by inv(l**h).
call stdlib${ii}$_${ci}$latrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT', normin,n, a, lda, &
work, sl, rwork, info )
end if
! divide x by 1/(sl*su) if doing so will not cause overflow.
scale = sl*su
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ci}$gecon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgetrf( m, n, a, lda, ipiv, info )
!! SGETRF computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_sgetrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_sgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_slaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_slaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, &
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_sgetrf
pure module subroutine stdlib${ii}$_dgetrf( m, n, a, lda, ipiv, info )
!! DGETRF computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_dgetrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_dgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_dlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_dlaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, &
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_dgetrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$getrf( m, n, a, lda, ipiv, info )
!! DGETRF: computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_${ri}$getrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_${ri}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_${ri}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_${ri}$laswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, &
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_${ri}$getrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgetrf( m, n, a, lda, ipiv, info )
!! CGETRF computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_cgetrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_cgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_claswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_claswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,&
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_cgetrf
pure module subroutine stdlib${ii}$_zgetrf( m, n, a, lda, ipiv, info )
!! ZGETRF computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_zgetrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_zgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_zlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_zlaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,&
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_zgetrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$getrf( m, n, a, lda, ipiv, info )
!! ZGETRF: computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 3 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, iinfo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then
! use unblocked code.
call stdlib${ii}$_${ci}$getrf2( m, n, a, lda, ipiv, info )
else
! use blocked code.
do j = 1, min( m, n ), nb
jb = min( min( m, n )-j+1, nb )
! factor diagonal and subdiagonal blocks and test for exact
! singularity.
call stdlib${ii}$_${ci}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
! adjust info and the pivot indices.
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$
do i = j, min( m, j+jb-1 )
ipiv( i ) = j - 1_${ik}$ + ipiv( i )
end do
! apply interchanges to columns 1:j-1.
call stdlib${ii}$_${ci}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ )
if( j+jb<=n ) then
! apply interchanges to columns j+jb:n.
call stdlib${ii}$_${ci}$laswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ )
! compute block row of u.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,&
a( j, j ), lda, a( j, j+jb ),lda )
if( j+jb<=m ) then
! update trailing submatrix.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -&
cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda )
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$getrf
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_sgetrf2( m, n, a, lda, ipiv, info )
!! SGETRF2 computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(sp) :: sfmin, temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for one row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==zero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for one column case
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_isamax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=zero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_sscal( m-1, one / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_sgetrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_slaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, one, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_sgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_slaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_sgetrf2
pure recursive module subroutine stdlib${ii}$_dgetrf2( m, n, a, lda, ipiv, info )
!! DGETRF2 computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(dp) :: sfmin, temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for one row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==zero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for one column case
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_idamax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=zero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_dscal( m-1, one / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_dgetrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_dlaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_dgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, one, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_dgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_dlaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dgetrf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ri}$getrf2( m, n, a, lda, ipiv, info )
!! DGETRF2: computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(${rk}$) :: sfmin, temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for one row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==zero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for one column case
! compute machine safe minimum
sfmin = stdlib${ii}$_${ri}$lamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_i${ri}$amax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=zero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_${ri}$scal( m-1, one / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_${ri}$getrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_${ri}$laswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, one, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_${ri}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_${ri}$laswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$getrf2
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_cgetrf2( m, n, a, lda, ipiv, info )
!! CGETRF2 computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(sp) :: sfmin
complex(sp) :: temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for cone row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==czero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for cone column case
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_icamax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=czero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_cscal( m-1, cone / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_cgetrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_claswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, cone, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_cgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_claswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_cgetrf2
pure recursive module subroutine stdlib${ii}$_zgetrf2( m, n, a, lda, ipiv, info )
!! ZGETRF2 computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(dp) :: sfmin
complex(dp) :: temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for cone row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==czero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for cone column case
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_izamax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=czero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_zscal( m-1, cone / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_zgetrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_zlaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, cone, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_zgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_zlaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zgetrf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ci}$getrf2( m, n, a, lda, ipiv, info )
!! ZGETRF2: computes an LU factorization of a general M-by-N matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = min(m,n)/2
!! [ A21 | A22 ] n2 = n-n1
!! [ A11 ]
!! The subroutine calls itself to factor [ --- ],
!! [ A12 ]
!! [ A12 ]
!! do the swaps on [ --- ], solve A12, update A22,
!! [ A22 ]
!! then calls itself to factor A22 and do the swaps on A21.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(${ck}$) :: sfmin
complex(${ck}$) :: temp
integer(${ik}$) :: i, iinfo, n1, n2
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
if ( m==1_${ik}$ ) then
! use unblocked code for cone row case
! just need to handle ipiv and info
ipiv( 1_${ik}$ ) = 1_${ik}$
if ( a(1_${ik}$,1_${ik}$)==czero )info = 1_${ik}$
else if( n==1_${ik}$ ) then
! use unblocked code for cone column case
! compute machine safe minimum
sfmin = stdlib${ii}$_${c2ri(ci)}$lamch('S')
! find pivot and test for singularity
i = stdlib${ii}$_i${ci}$amax( m, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ )
ipiv( 1_${ik}$ ) = i
if( a( i, 1_${ik}$ )/=czero ) then
! apply the interchange
if( i/=1_${ik}$ ) then
temp = a( 1_${ik}$, 1_${ik}$ )
a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ )
a( i, 1_${ik}$ ) = temp
end if
! compute elements 2:m of the column
if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then
call stdlib${ii}$_${ci}$scal( m-1, cone / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ )
else
do i = 1, m-1
a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ )
end do
end if
else
info = 1_${ik}$
end if
else
! use recursive code
n1 = min( m, n ) / 2_${ik}$
n2 = n-n1
! [ a11 ]
! factor [ --- ]
! [ a21 ]
call stdlib${ii}$_${ci}$getrf2( m, n1, a, lda, ipiv, iinfo )
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! [ a12 ]
! apply interchanges to [ --- ]
! [ a22 ]
call stdlib${ii}$_${ci}$laswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ )
! solve a12
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda )
! update a22
call stdlib${ii}$_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), &
lda, cone, a( n1+1, n1+1 ), lda )
! factor a22
call stdlib${ii}$_${ci}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo )
! adjust info and the pivot indices
if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1
do i = n1+1, min( m, n )
ipiv( i ) = ipiv( i ) + n1
end do
! apply interchanges to a21
call stdlib${ii}$_${ci}$laswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$getrf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgetf2( m, n, a, lda, ipiv, info )
!! SGETF2 computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(sp) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_isamax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=zero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_sswap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_sscal( m-j, one / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_sger( m-j, n-j, -one, a( j+1, j ), 1_${ik}$, a( j, j+1 ), lda,a( j+1, j+1 ),&
lda )
end if
end do
return
end subroutine stdlib${ii}$_sgetf2
pure module subroutine stdlib${ii}$_dgetf2( m, n, a, lda, ipiv, info )
!! DGETF2 computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(dp) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_idamax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=zero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_dswap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_dscal( m-j, one / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_dger( m-j, n-j, -one, a( j+1, j ), 1_${ik}$, a( j, j+1 ), lda,a( j+1, j+1 ),&
lda )
end if
end do
return
end subroutine stdlib${ii}$_dgetf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$getf2( m, n, a, lda, ipiv, info )
!! DGETF2: computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(${rk}$) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_${ri}$lamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=zero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_${ri}$swap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_${ri}$scal( m-j, one / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_${ri}$ger( m-j, n-j, -one, a( j+1, j ), 1_${ik}$, a( j, j+1 ), lda,a( j+1, j+1 ),&
lda )
end if
end do
return
end subroutine stdlib${ii}$_${ri}$getf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgetf2( m, n, a, lda, ipiv, info )
!! CGETF2 computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(sp) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_slamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_icamax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=czero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_cswap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_cscal( m-j, cone / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_cgeru( m-j, n-j, -cone, a( j+1, j ), 1_${ik}$, a( j, j+1 ),lda, a( j+1, j+1 &
), lda )
end if
end do
return
end subroutine stdlib${ii}$_cgetf2
pure module subroutine stdlib${ii}$_zgetf2( m, n, a, lda, ipiv, info )
!! ZGETF2 computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(dp) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_dlamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_izamax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=czero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_zswap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_zscal( m-j, cone / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_zgeru( m-j, n-j, -cone, a( j+1, j ), 1_${ik}$, a( j, j+1 ),lda, a( j+1, j+1 &
), lda )
end if
end do
return
end subroutine stdlib${ii}$_zgetf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$getf2( m, n, a, lda, ipiv, info )
!! ZGETF2: computes an LU factorization of a general m-by-n matrix A
!! using partial pivoting with row interchanges.
!! The factorization has the form
!! A = P * L * U
!! where P is a permutation matrix, L is lower triangular with unit
!! diagonal elements (lower trapezoidal if m > n), and U is upper
!! triangular (upper trapezoidal if m < n).
!! This is the right-looking Level 2 BLAS version of the algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
real(${ck}$) :: sfmin
integer(${ik}$) :: i, j, jp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! compute machine safe minimum
sfmin = stdlib${ii}$_${c2ri(ci)}$lamch('S')
do j = 1, min( m, n )
! find pivot and test for singularity.
jp = j - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( m-j+1, a( j, j ), 1_${ik}$ )
ipiv( j ) = jp
if( a( jp, j )/=czero ) then
! apply the interchange to columns 1:n.
if( jp/=j )call stdlib${ii}$_${ci}$swap( n, a( j, 1_${ik}$ ), lda, a( jp, 1_${ik}$ ), lda )
! compute elements j+1:m of j-th column.
if( j<m ) then
if( abs(a( j, j )) >= sfmin ) then
call stdlib${ii}$_${ci}$scal( m-j, cone / a( j, j ), a( j+1, j ), 1_${ik}$ )
else
do i = 1, m-j
a( j+i, j ) = a( j+i, j ) / a( j, j )
end do
end if
end if
else if( info==0_${ik}$ ) then
info = j
end if
if( j<min( m, n ) ) then
! update trailing submatrix.
call stdlib${ii}$_${ci}$geru( m-j, n-j, -cone, a( j+1, j ), 1_${ik}$, a( j, j+1 ),lda, a( j+1, j+1 &
), lda )
end if
end do
return
end subroutine stdlib${ii}$_${ci}$getf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! SGETRS solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by SGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_slaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,one, a, lda, b, &
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a**t * x = b.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'UNIT', n, nrhs, one,a, lda, b, &
ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_slaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_sgetrs
pure module subroutine stdlib${ii}$_dgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! DGETRS solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by DGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_dlaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,one, a, lda, b, &
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a**t * x = b.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'UNIT', n, nrhs, one,a, lda, b, &
ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_dlaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dgetrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$getrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! DGETRS: solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by DGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_${ri}$laswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,one, a, lda, b, &
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a**t * x = b.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'UNIT', n, nrhs, one,a, lda, b, &
ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_${ri}$laswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$getrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! CGETRS solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by CGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_claswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,cone, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a**t * x = b or a**h * x = b.
! solve u**t *x = b or u**h *x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', trans, 'NON-UNIT', n, nrhs, cone,a, lda, b, ldb &
)
! solve l**t *x = b, or l**h *x = b overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', trans, 'UNIT', n, nrhs, cone, a,lda, b, ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_claswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_cgetrs
pure module subroutine stdlib${ii}$_zgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! ZGETRS solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by ZGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_zlaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,cone, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a**t * x = b or a**h * x = b.
! solve u**t *x = b or u**h *x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', trans, 'NON-UNIT', n, nrhs, cone,a, lda, b, ldb &
)
! solve l**t *x = b, or l**h *x = b overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', trans, 'UNIT', n, nrhs, cone, a,lda, b, ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_zlaswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zgetrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$getrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!! ZGETRS: solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general N-by-N matrix A using the LU factorization computed
!! by ZGETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( notran ) then
! solve a * x = b.
! apply row interchanges to the right hand sides.
call stdlib${ii}$_${ci}$laswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, 1_${ik}$ )
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, nrhs,cone, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a**t * x = b or a**h * x = b.
! solve u**t *x = b or u**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', trans, 'NON-UNIT', n, nrhs, cone,a, lda, b, ldb &
)
! solve l**t *x = b, or l**h *x = b overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', trans, 'UNIT', n, nrhs, cone, a,lda, b, ldb )
! apply row interchanges to the solution vectors.
call stdlib${ii}$_${ci}$laswp( nrhs, b, ldb, 1_${ik}$, n, ipiv, -1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$getrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgetri( n, a, lda, ipiv, work, lwork, info )
!! SGETRI computes the inverse of a matrix using the LU factorization
!! computed by SGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_strtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_strtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = zero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n, n-j, -one, a( 1_${ik}$, j+1 ),lda, work( &
j+1 ), 1_${ik}$, one, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = zero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
one, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, one, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,one, work( j )&
, ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_sswap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_sgetri
pure module subroutine stdlib${ii}$_dgetri( n, a, lda, ipiv, work, lwork, info )
!! DGETRI computes the inverse of a matrix using the LU factorization
!! computed by DGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_dtrtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_dtrtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = zero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n, n-j, -one, a( 1_${ik}$, j+1 ),lda, work( &
j+1 ), 1_${ik}$, one, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = zero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
one, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, one, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,one, work( j )&
, ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_dswap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_dgetri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$getri( n, a, lda, ipiv, work, lwork, info )
!! DGETRI: computes the inverse of a matrix using the LU factorization
!! computed by DGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_${ri}$trtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_${ri}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = zero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n, n-j, -one, a( 1_${ik}$, j+1 ),lda, work( &
j+1 ), 1_${ik}$, one, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = zero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
one, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, one, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,one, work( j )&
, ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_${ri}$swap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ri}$getri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgetri( n, a, lda, ipiv, work, lwork, info )
!! CGETRI computes the inverse of a matrix using the LU factorization
!! computed by CGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_ctrtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_ctrtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = czero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n, n-j, -cone, a( 1_${ik}$, j+1 ),lda, work(&
j+1 ), 1_${ik}$, cone, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = czero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
cone, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, cone, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,cone, work( j &
), ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_cswap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_cgetri
pure module subroutine stdlib${ii}$_zgetri( n, a, lda, ipiv, work, lwork, info )
!! ZGETRI computes the inverse of a matrix using the LU factorization
!! computed by ZGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_ztrtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_ztrtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = czero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n, n-j, -cone, a( 1_${ik}$, j+1 ),lda, work(&
j+1 ), 1_${ik}$, cone, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = czero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
cone, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, cone, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,cone, work( j &
), ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_zswap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_zgetri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$getri( n, a, lda, ipiv, work, lwork, info )
!! ZGETRI: computes the inverse of a matrix using the LU factorization
!! computed by ZGETRF.
!! This method inverts U and then computes inv(A) by solving the system
!! inv(A)*L = inv(U) for inv(A).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
lquery = ( lwork==-1_${ik}$ )
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGETRI', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form inv(u). if info > 0 from stdlib${ii}$_${ci}$trtri, then u is singular,
! and the inverse is not computed.
call stdlib${ii}$_${ci}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info )
if( info>0 )return
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = max( ldwork*nb, 1_${ik}$ )
if( lwork<iws ) then
nb = lwork / ldwork
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = n
end if
! solve the equation inv(a)*l = inv(u) for inv(a).
if( nb<nbmin .or. nb>=n ) then
! use unblocked code.
do j = n, 1, -1
! copy current column of l to work and replace with zeros.
do i = j + 1, n
work( i ) = a( i, j )
a( i, j ) = czero
end do
! compute current column of inv(a).
if( j<n )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n, n-j, -cone, a( 1_${ik}$, j+1 ),lda, work(&
j+1 ), 1_${ik}$, cone, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! use blocked code.
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
! copy current block column of l to work and replace with
! zeros.
do jj = j, j + jb - 1
do i = jj + 1, n
work( i+( jj-j )*ldwork ) = a( i, jj )
a( i, jj ) = czero
end do
end do
! compute current block column of inv(a).
if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, jb,n-j-jb+1, -&
cone, a( 1_${ik}$, j+jb ), lda,work( j+jb ), ldwork, cone, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n, jb,cone, work( j &
), ldwork, a( 1_${ik}$, j ), lda )
end do
end if
! apply column interchanges.
do j = n - 1, 1, -1
jp = ipiv( j )
if( jp/=j )call stdlib${ii}$_${ci}$swap( n, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, jp ), 1_${ik}$ )
end do
work( 1_${ik}$ ) = iws
return
end subroutine stdlib${ii}$_${ci}$getri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! SGERFS improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_sgemv( trans, n, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_sgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_sgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_sgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_sgerfs
pure module subroutine stdlib${ii}$_dgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! DGERFS improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dgemv( trans, n, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_dgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_dgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dgerfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! DGERFS: improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( trans, n, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_${ri}$getrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_${ri}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$gerfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! CGERFS improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cgemv( trans, n, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work,1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_cgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cgetrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cgerfs
pure module subroutine stdlib${ii}$_zgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! ZGERFS improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zgemv( trans, n, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work,1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_zgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zgetrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zgerfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! ZGERFS: improves the computed solution to a system of linear
!! equations and provides error bounds and backward error estimates for
!! the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( trans, n, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work,1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
do i = 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_${ci}$getrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$getrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$gerfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! SGEEQU computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_sgeequ
pure module subroutine stdlib${ii}$_dgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! DGEEQU computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_dgeequ
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$geequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! DGEEQU: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(${rk}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ri}$geequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! CGEEQU computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(out) :: c(*), r(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, rcmax, rcmin, smlnum
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_cgeequ
pure module subroutine stdlib${ii}$_zgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! ZGEEQU computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(out) :: c(*), r(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, rcmax, rcmin, smlnum
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_zgeequ
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$geequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! ZGEEQU: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(${ck}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(out) :: c(*), r(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: bignum, rcmax, rcmin, smlnum
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ci}$geequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! SGEEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from SGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_slamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_sgeequb
pure module subroutine stdlib${ii}$_dgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! DGEEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from DGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_dlamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_dgeequb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$geequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! DGEEQUB: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from DGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(${rk}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_${ri}$lamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), abs( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ri}$geequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! CGEEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from CGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(out) :: c(*), r(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_slamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log(r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_cgeequb
pure module subroutine stdlib${ii}$_zgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! ZGEEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from ZGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(out) :: c(*), r(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_dlamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log(r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_zgeequb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$geequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info )
!! ZGEEQUB: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from ZGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, m, n
real(${ck}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(out) :: c(*), r(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
logrdx = log( radix )
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
do j = 1, n
do i = 1, m
r( i ) = max( r( i ), cabs1( a( i, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log(r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = 1, m
c( j ) = max( c( j ), cabs1( a( i, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ci}$geequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! SLAQGE equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_slaqge
pure module subroutine stdlib${ii}$_dlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! DLAQGE equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_dlaqge
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! DLAQGE: equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(${rk}$), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_${ri}$laqge
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! CLAQGE equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(sp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: c(*), r(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_claqge
pure module subroutine stdlib${ii}$_zlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! ZLAQGE equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(dp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: c(*), r(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_zlaqge
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed )
!! ZLAQGE: equilibrates a general M by N matrix A using the row and
!! column scaling factors in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: lda, m, n
real(${ck}$), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(in) :: c(*), r(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: cj, large, small
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*a( i, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = 1, m
a( i, j ) = r( i )*a( i, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = 1, m
a( i, j ) = cj*r( i )*a( i, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_${ci}$laqge
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaswp( n, a, lda, k1, k2, ipiv, incx )
!! SLASWP performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
real(sp) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_slaswp
pure module subroutine stdlib${ii}$_dlaswp( n, a, lda, k1, k2, ipiv, incx )
!! DLASWP performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
real(dp) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_dlaswp
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laswp( n, a, lda, k1, k2, ipiv, incx )
!! DLASWP: performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
real(${rk}$) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_${ri}$laswp
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claswp( n, a, lda, k1, k2, ipiv, incx )
!! CLASWP performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
complex(sp) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_claswp
pure module subroutine stdlib${ii}$_zlaswp( n, a, lda, k1, k2, ipiv, incx )
!! ZLASWP performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
complex(dp) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_zlaswp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laswp( n, a, lda, k1, k2, ipiv, incx )
!! ZLASWP: performs a series of row interchanges on the matrix A.
!! One row interchange is initiated for each of rows K1 through K2 of A.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k1, k2, lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32
complex(${ck}$) :: temp
! Executable Statements
! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows
! k1 through k2.
if( incx>0_${ik}$ ) then
ix0 = k1
i1 = k1
i2 = k2
inc = 1_${ik}$
else if( incx<0_${ik}$ ) then
ix0 = k1 + ( k1-k2 )*incx
i1 = k2
i2 = k1
inc = -1_${ik}$
else
return
end if
n32 = ( n / 32_${ik}$ )*32_${ik}$
if( n32/=0_${ik}$ ) then
do j = 1, n32, 32
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = j, j + 31
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end do
end if
if( n32/=n ) then
n32 = n32 + 1_${ik}$
ix = ix0
do i = i1, i2, inc
ip = ipiv( ix )
if( ip/=i ) then
do k = n32, n
temp = a( i, k )
a( i, k ) = a( ip, k )
a( ip, k ) = temp
end do
end if
ix = ix + incx
end do
end if
return
end subroutine stdlib${ii}$_${ci}$laswp
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgetc2( n, a, lda, ipiv, jpiv, info )
!! SGETC2 computes an LU factorization with complete pivoting of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is the Level 2 BLAS algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(sp) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = smlnum
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin.
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_sswap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_sswap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = smin
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_sger( n-i, n-i, -one, a( i+1, i ), 1_${ik}$, a( i, i+1 ), lda,a( i+1, i+1 ), &
lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = smin
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_sgetc2
pure module subroutine stdlib${ii}$_dgetc2( n, a, lda, ipiv, jpiv, info )
!! DGETC2 computes an LU factorization with complete pivoting of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is the Level 2 BLAS algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(dp) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = smlnum
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin.
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_dswap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_dswap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = smin
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_dger( n-i, n-i, -one, a( i+1, i ), 1_${ik}$, a( i, i+1 ), lda,a( i+1, i+1 ), &
lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = smin
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_dgetc2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$getc2( n, a, lda, ipiv, jpiv, info )
!! DGETC2: computes an LU factorization with complete pivoting of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is the Level 2 BLAS algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(${rk}$) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = smlnum
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin.
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_${ri}$swap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_${ri}$swap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = smin
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_${ri}$ger( n-i, n-i, -one, a( i+1, i ), 1_${ik}$, a( i, i+1 ), lda,a( i+1, i+1 ), &
lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = smin
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_${ri}$getc2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgetc2( n, a, lda, ipiv, jpiv, info )
!! CGETC2 computes an LU factorization, using complete pivoting, of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is a level 1 BLAS version of the algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(sp) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = cmplx( smlnum, zero,KIND=sp)
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_cswap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_cswap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = cmplx( smin, zero,KIND=sp)
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_cgeru( n-i, n-i, -cmplx( one,KIND=sp), a( i+1, i ), 1_${ik}$,a( i, i+1 ), lda, &
a( i+1, i+1 ), lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = cmplx( smin, zero,KIND=sp)
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_cgetc2
pure module subroutine stdlib${ii}$_zgetc2( n, a, lda, ipiv, jpiv, info )
!! ZGETC2 computes an LU factorization, using complete pivoting, of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is a level 1 BLAS version of the algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(dp) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = cmplx( smlnum, zero,KIND=dp)
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_zswap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_zswap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = cmplx( smin, zero,KIND=dp)
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_zgeru( n-i, n-i, -cmplx( one,KIND=dp), a( i+1, i ), 1_${ik}$,a( i, i+1 ), lda, &
a( i+1, i+1 ), lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = cmplx( smin, zero,KIND=dp)
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_zgetc2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$getc2( n, a, lda, ipiv, jpiv, info )
!! ZGETC2: computes an LU factorization, using complete pivoting, of the
!! n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!! where P and Q are permutation matrices, L is lower triangular with
!! unit diagonal elements and U is upper triangular.
!! This is a level 1 BLAS version of the algorithm.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*), jpiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, ipv, j, jp, jpv
real(${ck}$) :: bignum, eps, smin, smlnum, xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
! handle the case n=1 by itself
if( n==1_${ik}$ ) then
ipiv( 1_${ik}$ ) = 1_${ik}$
jpiv( 1_${ik}$ ) = 1_${ik}$
if( abs( a( 1_${ik}$, 1_${ik}$ ) )<smlnum ) then
info = 1_${ik}$
a( 1_${ik}$, 1_${ik}$ ) = cmplx( smlnum, zero,KIND=${ck}$)
end if
return
end if
! factorize a using complete pivoting.
! set pivots less than smin to smin
loop_40: do i = 1, n - 1
! find max element in matrix a
xmax = zero
do ip = i, n
do jp = i, n
if( abs( a( ip, jp ) )>=xmax ) then
xmax = abs( a( ip, jp ) )
ipv = ip
jpv = jp
end if
end do
end do
if( i==1_${ik}$ )smin = max( eps*xmax, smlnum )
! swap rows
if( ipv/=i )call stdlib${ii}$_${ci}$swap( n, a( ipv, 1_${ik}$ ), lda, a( i, 1_${ik}$ ), lda )
ipiv( i ) = ipv
! swap columns
if( jpv/=i )call stdlib${ii}$_${ci}$swap( n, a( 1_${ik}$, jpv ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpv
! check for singularity
if( abs( a( i, i ) )<smin ) then
info = i
a( i, i ) = cmplx( smin, zero,KIND=${ck}$)
end if
do j = i + 1, n
a( j, i ) = a( j, i ) / a( i, i )
end do
call stdlib${ii}$_${ci}$geru( n-i, n-i, -cmplx( one,KIND=${ck}$), a( i+1, i ), 1_${ik}$,a( i, i+1 ), lda, &
a( i+1, i+1 ), lda )
end do loop_40
if( abs( a( n, n ) )<smin ) then
info = n
a( n, n ) = cmplx( smin, zero,KIND=${ck}$)
end if
! set last pivots to n
ipiv( n ) = n
jpiv( n ) = n
return
end subroutine stdlib${ii}$_${ci}$getc2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! SGESC2 solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by SGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, eps, smlnum, temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_slaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_isamax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = ( one / two ) / abs( rhs( i ) )
call stdlib${ii}$_sscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*temp
end if
do i = n, 1, -1
temp = one / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_slaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_sgesc2
pure module subroutine stdlib${ii}$_dgesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! DGESC2 solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by DGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, eps, smlnum, temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_dlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_idamax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = ( one / two ) / abs( rhs( i ) )
call stdlib${ii}$_dscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*temp
end if
do i = n, 1, -1
temp = one / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_dlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_dgesc2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! DGESC2: solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by DGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: bignum, eps, smlnum, temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_i${ri}$amax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = ( one / two ) / abs( rhs( i ) )
call stdlib${ii}$_${ri}$scal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*temp
end if
do i = n, 1, -1
temp = one / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_${ri}$gesc2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! CGESC2 solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by CGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: bignum, eps, smlnum
complex(sp) :: temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_claswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_icamax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = cmplx( one / two, zero,KIND=sp) / abs( rhs( i ) )
call stdlib${ii}$_cscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*real( temp,KIND=sp)
end if
do i = n, 1, -1
temp = cmplx( one, zero,KIND=sp) / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_claswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_cgesc2
pure module subroutine stdlib${ii}$_zgesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! ZGESC2 solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by ZGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: bignum, eps, smlnum
complex(dp) :: temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_izamax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = cmplx( one / two, zero,KIND=dp) / abs( rhs( i ) )
call stdlib${ii}$_zscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*real( temp,KIND=dp)
end if
do i = n, 1, -1
temp = cmplx( one, zero,KIND=dp) / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_zgesc2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale )
!! ZGESC2: solves a system of linear equations
!! A * X = scale* RHS
!! with a general N-by-N matrix A using the LU factorization with
!! complete pivoting computed by ZGETC2.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: scale
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: rhs(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: bignum, eps, smlnum
complex(${ck}$) :: temp
! Intrinsic Functions
! Executable Statements
! set constant to control overflow
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
! apply permutations ipiv to rhs
call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l part
do i = 1, n - 1
do j = i + 1, n
rhs( j ) = rhs( j ) - a( j, i )*rhs( i )
end do
end do
! solve for u part
scale = one
! check for scaling
i = stdlib${ii}$_i${ci}$amax( n, rhs, 1_${ik}$ )
if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then
temp = cmplx( one / two, zero,KIND=${ck}$) / abs( rhs( i ) )
call stdlib${ii}$_${ci}$scal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ )
scale = scale*real( temp,KIND=${ck}$)
end if
do i = n, 1, -1
temp = cmplx( one, zero,KIND=${ck}$) / a( i, i )
rhs( i ) = rhs( i )*temp
do j = i + 1, n
rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp )
end do
end do
! apply permutations jpiv to the solution (rhs)
call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
return
end subroutine stdlib${ii}$_${ci}$gesc2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! SLATDF uses the LU factorization of the n-by-n matrix Z computed by
!! SGETC2 and computes a contribution to the reciprocal Dif-estimate
!! by solving Z * x = b for x, and choosing the r.h.s. b such that
!! the norm of x is as large as possible. On entry RHS = b holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,
!! where P and Q are permutation matrices. L is lower triangular with
!! unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(sp), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(sp), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 8_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(sp) :: bm, bp, pmone, sminu, splus, temp
! Local Arrays
integer(${ik}$) :: iwork(maxdim)
real(sp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_slaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -one
loop_10: do j = 1, n - 1
bp = rhs( j ) + one
bm = rhs( j ) - one
splus = one
! look-ahead for l-part rhs(1:n-1) = + or -1, splus and
! smin computed more efficiently than in bsolve [1].
splus = splus + stdlib${ii}$_sdot( n-j, z( j+1, j ), 1_${ik}$, z( j+1, j ), 1_${ik}$ )
sminu = stdlib${ii}$_sdot( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
splus = splus*rhs( j )
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens
! we choose -1, thereafter +1. this is a simple way to
! get good estimates of matrices like byers well-known
! example (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = one
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_saxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u-part, look-ahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_scopy( n-1, rhs, 1_${ik}$, xp, 1_${ik}$ )
xp( n ) = rhs( n ) + one
rhs( n ) = rhs( n ) - one
splus = zero
sminu = zero
do i = n, 1, -1
temp = one / z( i, i )
xp( i ) = xp( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
xp( i ) = xp( i ) - xp( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( xp( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_scopy( n, xp, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_slaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_slassq( n, rhs, 1_${ik}$, rdscal, rdsum )
else
! ijob = 2, compute approximate nullvector xm of z
call stdlib${ii}$_sgecon( 'I', n, z, ldz, one, temp, work, iwork, info )
call stdlib${ii}$_scopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_slaswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = one / sqrt( stdlib${ii}$_sdot( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_scopy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_saxpy( n, one, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_saxpy( n, -one, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_sgesc2( n, z, ldz, rhs, ipiv, jpiv, temp )
call stdlib${ii}$_sgesc2( n, z, ldz, xp, ipiv, jpiv, temp )
if( stdlib${ii}$_sasum( n, xp, 1_${ik}$ )>stdlib${ii}$_sasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_scopy( n, xp, 1_${ik}$,&
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_slassq( n, rhs, 1_${ik}$, rdscal, rdsum )
end if
return
end subroutine stdlib${ii}$_slatdf
pure module subroutine stdlib${ii}$_dlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! DLATDF uses the LU factorization of the n-by-n matrix Z computed by
!! DGETC2 and computes a contribution to the reciprocal Dif-estimate
!! by solving Z * x = b for x, and choosing the r.h.s. b such that
!! the norm of x is as large as possible. On entry RHS = b holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
!! where P and Q are permutation matrices. L is lower triangular with
!! unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(dp), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(dp), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 8_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(dp) :: bm, bp, pmone, sminu, splus, temp
! Local Arrays
integer(${ik}$) :: iwork(maxdim)
real(dp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_dlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -one
loop_10: do j = 1, n - 1
bp = rhs( j ) + one
bm = rhs( j ) - one
splus = one
! look-ahead for l-part rhs(1:n-1) = + or -1, splus and
! smin computed more efficiently than in bsolve [1].
splus = splus + stdlib${ii}$_ddot( n-j, z( j+1, j ), 1_${ik}$, z( j+1, j ), 1_${ik}$ )
sminu = stdlib${ii}$_ddot( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
splus = splus*rhs( j )
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens
! we choose -1, thereafter +1. this is a simple way to
! get good estimates of matrices like byers well-known
! example (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = one
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_daxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u-part, look-ahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_dcopy( n-1, rhs, 1_${ik}$, xp, 1_${ik}$ )
xp( n ) = rhs( n ) + one
rhs( n ) = rhs( n ) - one
splus = zero
sminu = zero
do i = n, 1, -1
temp = one / z( i, i )
xp( i ) = xp( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
xp( i ) = xp( i ) - xp( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( xp( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_dcopy( n, xp, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_dlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_dlassq( n, rhs, 1_${ik}$, rdscal, rdsum )
else
! ijob = 2, compute approximate nullvector xm of z
call stdlib${ii}$_dgecon( 'I', n, z, ldz, one, temp, work, iwork, info )
call stdlib${ii}$_dcopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_dlaswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = one / sqrt( stdlib${ii}$_ddot( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_dcopy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_daxpy( n, one, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_daxpy( n, -one, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_dgesc2( n, z, ldz, rhs, ipiv, jpiv, temp )
call stdlib${ii}$_dgesc2( n, z, ldz, xp, ipiv, jpiv, temp )
if( stdlib${ii}$_dasum( n, xp, 1_${ik}$ )>stdlib${ii}$_dasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_dcopy( n, xp, 1_${ik}$,&
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_dlassq( n, rhs, 1_${ik}$, rdscal, rdsum )
end if
return
end subroutine stdlib${ii}$_dlatdf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! DLATDF: uses the LU factorization of the n-by-n matrix Z computed by
!! DGETC2 and computes a contribution to the reciprocal Dif-estimate
!! by solving Z * x = b for x, and choosing the r.h.s. b such that
!! the norm of x is as large as possible. On entry RHS = b holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
!! where P and Q are permutation matrices. L is lower triangular with
!! unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(${rk}$), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
real(${rk}$), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 8_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(${rk}$) :: bm, bp, pmone, sminu, splus, temp
! Local Arrays
integer(${ik}$) :: iwork(maxdim)
real(${rk}$) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -one
loop_10: do j = 1, n - 1
bp = rhs( j ) + one
bm = rhs( j ) - one
splus = one
! look-ahead for l-part rhs(1:n-1) = + or -1, splus and
! smin computed more efficiently than in bsolve [1].
splus = splus + stdlib${ii}$_${ri}$dot( n-j, z( j+1, j ), 1_${ik}$, z( j+1, j ), 1_${ik}$ )
sminu = stdlib${ii}$_${ri}$dot( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
splus = splus*rhs( j )
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens
! we choose -1, thereafter +1. this is a simple way to
! get good estimates of matrices like byers well-known
! example (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = one
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_${ri}$axpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u-part, look-ahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_${ri}$copy( n-1, rhs, 1_${ik}$, xp, 1_${ik}$ )
xp( n ) = rhs( n ) + one
rhs( n ) = rhs( n ) - one
splus = zero
sminu = zero
do i = n, 1, -1
temp = one / z( i, i )
xp( i ) = xp( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
xp( i ) = xp( i ) - xp( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( xp( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_${ri}$copy( n, xp, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_${ri}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum )
else
! ijob = 2, compute approximate nullvector xm of z
call stdlib${ii}$_${ri}$gecon( 'I', n, z, ldz, one, temp, work, iwork, info )
call stdlib${ii}$_${ri}$copy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_${ri}$laswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = one / sqrt( stdlib${ii}$_${ri}$dot( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n, one, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n, -one, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_${ri}$gesc2( n, z, ldz, rhs, ipiv, jpiv, temp )
call stdlib${ii}$_${ri}$gesc2( n, z, ldz, xp, ipiv, jpiv, temp )
if( stdlib${ii}$_${ri}$asum( n, xp, 1_${ik}$ )>stdlib${ii}$_${ri}$asum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_${ri}$copy( n, xp, 1_${ik}$,&
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_${ri}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum )
end if
return
end subroutine stdlib${ii}$_${ri}$latdf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! CLATDF computes the contribution to the reciprocal Dif-estimate
!! by solving for x in Z * x = b, where b is chosen such that the norm
!! of x is as large as possible. It is assumed that LU decomposition
!! of Z has been computed by CGETC2. On entry RHS = f holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by CGETC2 has the form
!! Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
!! triangular with unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(sp), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(sp), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 2_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(sp) :: rtemp, scale, sminu, splus
complex(sp) :: bm, bp, pmone, temp
! Local Arrays
real(sp) :: rwork(maxdim)
complex(sp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_claswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -cone
loop_10: do j = 1, n - 1
bp = rhs( j ) + cone
bm = rhs( j ) - cone
splus = one
! lockahead for l- part rhs(1:n-1) = +-1
! splus and smin computed more efficiently than in bsolve[1].
splus = splus + real( stdlib${ii}$_cdotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=sp)
sminu = real( stdlib${ii}$_cdotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=sp)
splus = splus*real( rhs( j ),KIND=sp)
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens we
! choose -1, thereafter +1. this is a simple way to get
! good estimates of matrices like byers well-known example
! (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = cone
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_caxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u- part, lockahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_ccopy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ )
work( n ) = rhs( n ) + cone
rhs( n ) = rhs( n ) - cone
splus = zero
sminu = zero
do i = n, 1, -1
temp = cone / z( i, i )
work( i ) = work( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
work( i ) = work( i ) - work( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( work( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_ccopy( n, work, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_claswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_classq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end if
! entry ijob = 2
! compute approximate nullvector xm of z
call stdlib${ii}$_cgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info )
call stdlib${ii}$_ccopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_claswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = cone / sqrt( stdlib${ii}$_cdotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_cscal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_ccopy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_caxpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_caxpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_cgesc2( n, z, ldz, rhs, ipiv, jpiv, scale )
call stdlib${ii}$_cgesc2( n, z, ldz, xp, ipiv, jpiv, scale )
if( stdlib${ii}$_scasum( n, xp, 1_${ik}$ )>stdlib${ii}$_scasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_ccopy( n, xp, 1_${ik}$, &
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_classq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end subroutine stdlib${ii}$_clatdf
pure module subroutine stdlib${ii}$_zlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! ZLATDF computes the contribution to the reciprocal Dif-estimate
!! by solving for x in Z * x = b, where b is chosen such that the norm
!! of x is as large as possible. It is assumed that LU decomposition
!! of Z has been computed by ZGETC2. On entry RHS = f holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by ZGETC2 has the form
!! Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
!! triangular with unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(dp), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(dp), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 2_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(dp) :: rtemp, scale, sminu, splus
complex(dp) :: bm, bp, pmone, temp
! Local Arrays
real(dp) :: rwork(maxdim)
complex(dp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -cone
loop_10: do j = 1, n - 1
bp = rhs( j ) + cone
bm = rhs( j ) - cone
splus = one
! lockahead for l- part rhs(1:n-1) = +-1
! splus and smin computed more efficiently than in bsolve[1].
splus = splus + real( stdlib${ii}$_zdotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=dp)
sminu = real( stdlib${ii}$_zdotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=dp)
splus = splus*real( rhs( j ),KIND=dp)
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens we
! choose -1, thereafter +1. this is a simple way to get
! good estimates of matrices like byers well-known example
! (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = cone
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_zaxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u- part, lockahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_zcopy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ )
work( n ) = rhs( n ) + cone
rhs( n ) = rhs( n ) - cone
splus = zero
sminu = zero
do i = n, 1, -1
temp = cone / z( i, i )
work( i ) = work( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
work( i ) = work( i ) - work( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( work( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_zcopy( n, work, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_zlassq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end if
! entry ijob = 2
! compute approximate nullvector xm of z
call stdlib${ii}$_zgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info )
call stdlib${ii}$_zcopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_zlaswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = cone / sqrt( stdlib${ii}$_zdotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_zscal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_zcopy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_zaxpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_zaxpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_zgesc2( n, z, ldz, rhs, ipiv, jpiv, scale )
call stdlib${ii}$_zgesc2( n, z, ldz, xp, ipiv, jpiv, scale )
if( stdlib${ii}$_dzasum( n, xp, 1_${ik}$ )>stdlib${ii}$_dzasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_zcopy( n, xp, 1_${ik}$, &
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_zlassq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end subroutine stdlib${ii}$_zlatdf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv )
!! ZLATDF: computes the contribution to the reciprocal Dif-estimate
!! by solving for x in Z * x = b, where b is chosen such that the norm
!! of x is as large as possible. It is assumed that LU decomposition
!! of Z has been computed by ZGETC2. On entry RHS = f holds the
!! contribution from earlier solved sub-systems, and on return RHS = x.
!! The factorization of Z returned by ZGETC2 has the form
!! Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
!! triangular with unit diagonal elements and U is upper triangular.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ijob, ldz, n
real(${ck}$), intent(inout) :: rdscal, rdsum
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*), jpiv(*)
complex(${ck}$), intent(inout) :: rhs(*), z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxdim = 2_${ik}$
! Local Scalars
integer(${ik}$) :: i, info, j, k
real(${ck}$) :: rtemp, scale, sminu, splus
complex(${ck}$) :: bm, bp, pmone, temp
! Local Arrays
real(${ck}$) :: rwork(maxdim)
complex(${ck}$) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim)
! Intrinsic Functions
! Executable Statements
if( ijob/=2_${ik}$ ) then
! apply permutations ipiv to rhs
call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ )
! solve for l-part choosing rhs either to +1 or -1.
pmone = -cone
loop_10: do j = 1, n - 1
bp = rhs( j ) + cone
bm = rhs( j ) - cone
splus = one
! lockahead for l- part rhs(1:n-1) = +-1
! splus and smin computed more efficiently than in bsolve[1].
splus = splus + real( stdlib${ii}$_${ci}$dotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=${ck}$)
sminu = real( stdlib${ii}$_${ci}$dotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=${ck}$)
splus = splus*real( rhs( j ),KIND=${ck}$)
if( splus>sminu ) then
rhs( j ) = bp
else if( sminu>splus ) then
rhs( j ) = bm
else
! in this case the updating sums are equal and we can
! choose rhs(j) +1 or -1. the first time this happens we
! choose -1, thereafter +1. this is a simple way to get
! good estimates of matrices like byers well-known example
! (see [1]). (not done in bsolve.)
rhs( j ) = rhs( j ) + pmone
pmone = cone
end if
! compute the remaining r.h.s.
temp = -rhs( j )
call stdlib${ii}$_${ci}$axpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ )
end do loop_10
! solve for u- part, lockahead for rhs(n) = +-1. this is not done
! in bsolve and will hopefully give us a better estimate because
! any ill-conditioning of the original matrix is transferred to u
! and not to l. u(n, n) is an approximation to sigma_min(lu).
call stdlib${ii}$_${ci}$copy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ )
work( n ) = rhs( n ) + cone
rhs( n ) = rhs( n ) - cone
splus = zero
sminu = zero
do i = n, 1, -1
temp = cone / z( i, i )
work( i ) = work( i )*temp
rhs( i ) = rhs( i )*temp
do k = i + 1, n
work( i ) = work( i ) - work( k )*( z( i, k )*temp )
rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
end do
splus = splus + abs( work( i ) )
sminu = sminu + abs( rhs( i ) )
end do
if( splus>sminu )call stdlib${ii}$_${ci}$copy( n, work, 1_${ik}$, rhs, 1_${ik}$ )
! apply the permutations jpiv to the computed solution (rhs)
call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_${ci}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end if
! entry ijob = 2
! compute approximate nullvector xm of z
call stdlib${ii}$_${ci}$gecon( 'I', n, z, ldz, one, rtemp, work, rwork, info )
call stdlib${ii}$_${ci}$copy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ )
! compute rhs
call stdlib${ii}$_${ci}$laswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ )
temp = cone / sqrt( stdlib${ii}$_${ci}$dotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) )
call stdlib${ii}$_${ci}$scal( n, temp, xm, 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( n, xm, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ )
call stdlib${ii}$_${ci}$gesc2( n, z, ldz, rhs, ipiv, jpiv, scale )
call stdlib${ii}$_${ci}$gesc2( n, z, ldz, xp, ipiv, jpiv, scale )
if( stdlib${ii}$_${c2ri(ci)}$zasum( n, xp, 1_${ik}$ )>stdlib${ii}$_${c2ri(ci)}$zasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_${ci}$copy( n, xp, 1_${ik}$, &
rhs, 1_${ik}$ )
! compute the sum of squares
call stdlib${ii}$_${ci}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum )
return
end subroutine stdlib${ii}$_${ci}$latdf
#:endif
#:endfor
real(sp) module function stdlib${ii}$_sla_gercond( trans, n, a, lda, af, ldaf, ipiv,cmode, c, info, work, &
!! SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j
real(sp) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_sla_gercond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLA_GERCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_sla_gercond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if (notrans) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work(i) = work(i) * work(2_${ik}$*n+i)
end do
if (notrans) then
call stdlib${ii}$_sgetrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_sgetrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if (notrans) then
call stdlib${ii}$_sgetrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_sgetrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= 0.0_sp )stdlib${ii}$_sla_gercond = ( one / ainvnm )
return
end function stdlib${ii}$_sla_gercond
real(dp) module function stdlib${ii}$_dla_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, &
!! DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j
real(dp) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_dla_gercond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_GERCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_dla_gercond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if (notrans) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work(i) = work(i) * work(2_${ik}$*n+i)
end do
if (notrans) then
call stdlib${ii}$_dgetrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_dgetrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if (notrans) then
call stdlib${ii}$_dgetrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_dgetrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_dla_gercond = ( one / ainvnm )
return
end function stdlib${ii}$_dla_gercond
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$la_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, &
!! DLA_GERCOND: estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j
real(${rk}$) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_${ri}$la_gercond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_GERCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_${ri}$la_gercond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if (notrans) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work(i) = work(i) * work(2_${ik}$*n+i)
end do
if (notrans) then
call stdlib${ii}$_${ri}$getrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_${ri}$getrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if (notrans) then
call stdlib${ii}$_${ri}$getrs( 'TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
else
call stdlib${ii}$_${ri}$getrs( 'NO TRANSPOSE', n, 1_${ik}$, af, ldaf, ipiv,work, n, info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_${ri}$la_gercond = ( one / ainvnm )
return
end function stdlib${ii}$_${ri}$la_gercond
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, &
!! SGBCON estimates the reciprocal of the condition number of a real
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by SGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(sp) :: ainvnm, scale, smlnum, t
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_saxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_slatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(u**t).
call stdlib${ii}$_slatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, &
work, scale, work( 2_${ik}$*n+1 ),info )
! multiply by inv(l**t).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_sdot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_sgbcon
pure module subroutine stdlib${ii}$_dgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, &
!! DGBCON estimates the reciprocal of the condition number of a real
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by DGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(dp) :: ainvnm, scale, smlnum, t
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_daxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_dlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(u**t).
call stdlib${ii}$_dlatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, &
work, scale, work( 2_${ik}$*n+1 ),info )
! multiply by inv(l**t).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_ddot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_dgbcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, &
!! DGBCON: estimates the reciprocal of the condition number of a real
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by DGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(${rk}$) :: ainvnm, scale, smlnum, t
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_${ri}$axpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_${ri}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(u**t).
call stdlib${ii}$_${ri}$latbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, &
work, scale, work( 2_${ik}$*n+1 ),info )
! multiply by inv(l**t).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_${ri}$dot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_${ri}$gbcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, &
!! CGBCON estimates the reciprocal of the condition number of a complex
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by CGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: ab(ldab,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(sp) :: ainvnm, scale, smlnum
complex(sp) :: t, zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_caxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_clatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, rwork, info )
else
! multiply by inv(u**h).
call stdlib${ii}$_clatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, &
ab, ldab, work, scale, rwork,info )
! multiply by inv(l**h).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_cdotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_cgbcon
pure module subroutine stdlib${ii}$_zgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, &
!! ZGBCON estimates the reciprocal of the condition number of a complex
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by ZGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: ab(ldab,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(dp) :: ainvnm, scale, smlnum
complex(dp) :: t, zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_zaxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_zlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, rwork, info )
else
! multiply by inv(u**h).
call stdlib${ii}$_zlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, &
ab, ldab, work, scale, rwork,info )
! multiply by inv(l**h).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_zdotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_zgbcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, &
!! ZGBCON: estimates the reciprocal of the condition number of a complex
!! general band matrix A, in either the 1-norm or the infinity-norm,
!! using the LU factorization computed by ZGBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as
!! RCOND = 1 / ( norm(A) * norm(inv(A)) ).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, onenrm
character :: normin
integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm
real(${ck}$) :: ainvnm, scale, smlnum
complex(${ck}$) :: t, zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<2_${ik}$*kl+ku+1 ) then
info = -6_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
! estimate the norm of inv(a).
ainvnm = zero
normin = 'N'
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kd = kl + ku + 1_${ik}$
lnoti = kl>0_${ik}$
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(l).
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
jp = ipiv( j )
t = work( jp )
if( jp/=j ) then
work( jp ) = work( j )
work( j ) = t
end if
call stdlib${ii}$_${ci}$axpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ )
end do
end if
! multiply by inv(u).
call stdlib${ii}$_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, &
ldab, work, scale, rwork, info )
else
! multiply by inv(u**h).
call stdlib${ii}$_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, &
ab, ldab, work, scale, rwork,info )
! multiply by inv(l**h).
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
work( j ) = work( j ) - stdlib${ii}$_${ci}$dotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ )
jp = ipiv( j )
if( jp/=j ) then
t = work( jp )
work( jp ) = work( j )
work( j ) = t
end if
end do
end if
end if
! divide x by 1/scale if doing so will not cause overflow.
normin = 'Y'
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
40 continue
return
end subroutine stdlib${ii}$_${ci}$gbcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! SGBTRF computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
real(sp) :: temp
! Local Arrays
real(sp) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! zero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = zero
end do
end do
! zero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = zero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to zero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_isamax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=zero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_sswap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_sswap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_sscal( km, one / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_sger( km, jm-jj, -one, ab( kv+2, jj ), 1_${ik}$,ab( kv, jj+&
1_${ik}$ ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_scopy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_slaswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_slaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(&
kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( &
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+1, j+jb ), &
ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+kl+1-jb, j+jb ), &
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(&
kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( &
kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, &
work31, ldwork, work13,ldwork, one, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_scopy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_sgbtrf
pure module subroutine stdlib${ii}$_dgbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! DGBTRF computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
real(dp) :: temp
! Local Arrays
real(dp) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! zero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = zero
end do
end do
! zero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = zero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to zero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_idamax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=zero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_dswap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_dswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_dswap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_dscal( km, one / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_dger( km, jm-jj, -one, ab( kv+2, jj ), 1_${ik}$,ab( kv, jj+&
1_${ik}$ ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_dcopy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_dlaswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_dlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(&
kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( &
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+1, j+jb ), &
ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+kl+1-jb, j+jb ), &
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(&
kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( &
kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, &
work31, ldwork, work13,ldwork, one, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_dswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_dswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_dcopy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_dgbtrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! DGBTRF: computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
real(${rk}$) :: temp
! Local Arrays
real(${rk}$) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_${ri}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! zero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = zero
end do
end do
! zero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = zero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to zero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_i${ri}$amax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=zero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_${ri}$swap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_${ri}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_${ri}$swap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_${ri}$scal( km, one / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_${ri}$ger( km, jm-jj, -one, ab( kv+2, jj ), 1_${ik}$,ab( kv, jj+&
1_${ik}$ ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_${ri}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_${ri}$laswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_${ri}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(&
kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( &
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+1, j+jb ), &
ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+kl+1-jb, j+jb ), &
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(&
kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( &
kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, &
work31, ldwork, work13,ldwork, one, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_${ri}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_${ri}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_${ri}$copy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_${ri}$gbtrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! CGBTRF computes an LU factorization of a complex m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
complex(sp) :: temp
! Local Arrays
complex(sp) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! czero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = czero
end do
end do
! czero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = czero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to czero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_icamax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=czero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_cswap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_cswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_cswap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_cscal( km, cone / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_cgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, &
jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_ccopy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_claswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_claswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, &
ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )&
, ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),&
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, &
ab( kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, &
work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_cswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_cswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_ccopy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_cgbtrf
pure module subroutine stdlib${ii}$_zgbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
complex(dp) :: temp
! Local Arrays
complex(dp) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! czero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = czero
end do
end do
! czero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = czero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to czero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_izamax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=czero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_zswap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_zswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_zswap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_zscal( km, cone / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_zgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, &
jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_zcopy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_zlaswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_zlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, &
ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )&
, ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),&
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, &
ab( kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, &
work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_zswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_zswap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_zcopy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_zgbtrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info )
!! ZGBTRF: computes an LU factorization of a complex m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 64_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, &
nw
complex(${ck}$) :: temp
! Local Arrays
complex(${ck}$) :: work13(ldwork,nbmax), work31(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTRF', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! determine the block size for this environment
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGBTRF', ' ', m, n, kl, ku )
! the block size must not exceed the limit set by the size of the
! local arrays work13 and work31.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kl ) then
! use unblocked code
call stdlib${ii}$_${ci}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
else
! use blocked code
! czero the superdiagonal elements of the work array work13
do j = 1, nb
do i = 1, j - 1
work13( i, j ) = czero
end do
end do
! czero the subdiagonal elements of the work array work31
do j = 1, nb
do i = j + 1, nb
work31( i, j ) = czero
end do
end do
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current
! stage of the factorization
ju = 1_${ik}$
loop_180: do j = 1, min( m, n ), nb
jb = min( nb, min( m, n )-j+1 )
! the active part of the matrix is partitioned
! a11 a12 a13
! a21 a22 a23
! a31 a32 a33
! here a11, a21 and a31 denote the current block of jb columns
! which is about to be factorized. the number of rows in the
! partitioning are jb, i2, i3 respectively, and the numbers
! of columns are jb, j2, j3. the superdiagonal elements of a13
! and the subdiagonal elements of a31 lie outside the band.
i2 = min( kl-jb, m-j-jb+1 )
i3 = min( jb, m-j-kl+1 )
! j2 and j3 are computed after ju has been updated.
! factorize the current block of jb columns
loop_80: do jj = j, j + jb - 1
! set fill-in elements in column jj+kv to czero
if( jj+kv<=n ) then
do i = 1, kl
ab( i, jj+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-jj )
jp = stdlib${ii}$_i${ci}$amax( km+1, ab( kv+1, jj ), 1_${ik}$ )
ipiv( jj ) = jp + jj - j
if( ab( kv+jp, jj )/=czero ) then
ju = max( ju, min( jj+ku+jp-1, n ) )
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to j+jb-1
if( jp+jj-1<j+kl ) then
call stdlib${ii}$_${ci}$swap( jb, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j )&
, ldab-1 )
else
! the interchange affects columns j to jj-1 of a31
! which are stored in the work array work31
call stdlib${ii}$_${ci}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-&
kl, 1_${ik}$ ), ldwork )
call stdlib${ii}$_${ci}$swap( j+jb-jj, ab( kv+1, jj ), ldab-1,ab( kv+jp, jj ), &
ldab-1 )
end if
end if
! compute multipliers
call stdlib${ii}$_${ci}$scal( km, cone / ab( kv+1, jj ), ab( kv+2, jj ),1_${ik}$ )
! update trailing submatrix within the band and within
! the current block. jm is the index of the last column
! which needs to be updated.
jm = min( ju, j+jb-1 )
if( jm>jj )call stdlib${ii}$_${ci}$geru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, &
jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 )
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = jj
end if
! copy current column of a31 into the work array work31
nw = min( jj-j+1, i3 )
if( nw>0_${ik}$ )call stdlib${ii}$_${ci}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )&
, 1_${ik}$ )
end do loop_80
if( j+jb<=n ) then
! apply the row interchanges to the other blocks.
j2 = min( ju-j+1, kv ) - jb
j3 = max( 0_${ik}$, ju-j-kv+1 )
! use stdlib_${ci}$laswp to apply the row interchanges to a12, a22, and
! a32.
call stdlib${ii}$_${ci}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ )
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
! apply the row interchanges to a13, a23, and a33
! columnwise.
k2 = j - 1_${ik}$ + jb + j2
do i = 1, j3
jj = k2 + i
do ii = j + i - 1, j + jb - 1
ip = ipiv( ii )
if( ip/=ii ) then
temp = ab( kv+1+ii-jj, jj )
ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj )
ab( kv+1+ip-jj, jj ) = temp
end if
end do
end do
! update the relevant part of the trailing submatrix
if( j2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, &
ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 )
if( i2>0_${ik}$ ) then
! update a22
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )&
, ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a32
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, &
work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),&
ldab-1 )
end if
end if
if( j3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array
! work13
do jj = 1, j3
do ii = jj, jb
work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 )
end do
end do
! update a13 in the work array
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, &
ab( kv+1, j ), ldab-1,work13, ldwork )
if( i2>0_${ik}$ ) then
! update a23
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(&
kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 )
end if
if( i3>0_${ik}$ ) then
! update a33
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, &
work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 )
end if
! copy the lower triangle of a13 back into place
do jj = 1, j3
do ii = jj, jb
ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj )
end do
end do
end if
else
! adjust the pivot indices.
do i = j, j + jb - 1
ipiv( i ) = ipiv( i ) + j - 1_${ik}$
end do
end if
! partially undo the interchanges in the current block to
! restore the upper triangular form of a31 and copy the upper
! triangle of a31 back into place
do jj = j + jb - 1, j, -1
jp = ipiv( jj ) - jj + 1_${ik}$
if( jp/=1_${ik}$ ) then
! apply interchange to columns j to jj-1
if( jp+jj-1<j+kl ) then
! the interchange does not affect a31
call stdlib${ii}$_${ci}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,ab( kv+jp+jj-j, j ),&
ldab-1 )
else
! the interchange does affect a31
call stdlib${ii}$_${ci}$swap( jj-j, ab( kv+1+jj-j, j ), ldab-1,work31( jp+jj-j-kl, &
1_${ik}$ ), ldwork )
end if
end if
! copy the current column of a31 back into place
nw = min( i3, jj-j+1 )
if( nw>0_${ik}$ )call stdlib${ii}$_${ci}$copy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )&
, 1_${ik}$ )
end do
end do loop_180
end if
return
end subroutine stdlib${ii}$_${ci}$gbtrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! SGBTF2 computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to zero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_isamax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=zero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_sswap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_sscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_sger( km, ju-j, -one, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_sgbtf2
pure module subroutine stdlib${ii}$_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! DGBTF2 computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to zero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_idamax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=zero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_dswap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_dscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_dger( km, ju-j, -one, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_dgbtf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! DGBTF2: computes an LU factorization of a real m-by-n band matrix A
!! using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to zero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = zero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to zero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = zero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_i${ri}$amax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=zero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_${ri}$swap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_${ri}$scal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_${ri}$ger( km, ju-j, -one, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is zero, set info to the index of the pivot
! unless a zero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_${ri}$gbtf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! CGBTF2 computes an LU factorization of a complex m-by-n band matrix
!! A using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to czero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_icamax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=czero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_cswap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_cscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_cgeru( km, ju-j, -cone, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_cgbtf2
pure module subroutine stdlib${ii}$_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
!! A using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to czero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_izamax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=czero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_zswap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_zscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_zgeru( km, ju-j, -cone, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_zgbtf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info )
!! ZGBTF2: computes an LU factorization of a complex m-by-n band matrix
!! A using partial pivoting with row interchanges.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, jp, ju, km, kv
! Intrinsic Functions
! Executable Statements
! kv is the number of superdiagonals in the factor u, allowing for
! fill-in.
kv = ku + kl
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+kv+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTF2', -info )
return
end if
! quick return if possible
if( m==0 .or. n==0 )return
! gaussian elimination with partial pivoting
! set fill-in elements in columns ku+2 to kv to czero.
do j = ku + 2, min( kv, n )
do i = kv - j + 2, kl
ab( i, j ) = czero
end do
end do
! ju is the index of the last column affected by the current stage
! of the factorization.
ju = 1_${ik}$
loop_40: do j = 1, min( m, n )
! set fill-in elements in column j+kv to czero.
if( j+kv<=n ) then
do i = 1, kl
ab( i, j+kv ) = czero
end do
end if
! find pivot and test for singularity. km is the number of
! subdiagonal elements in the current column.
km = min( kl, m-j )
jp = stdlib${ii}$_i${ci}$amax( km+1, ab( kv+1, j ), 1_${ik}$ )
ipiv( j ) = jp + j - 1_${ik}$
if( ab( kv+jp, j )/=czero ) then
ju = max( ju, min( j+ku+jp-1, n ) )
! apply interchange to columns j to ju.
if( jp/=1_${ik}$ )call stdlib${ii}$_${ci}$swap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-&
1_${ik}$ )
if( km>0_${ik}$ ) then
! compute multipliers.
call stdlib${ii}$_${ci}$scal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ )
! update trailing submatrix within the band.
if( ju>j )call stdlib${ii}$_${ci}$geru( km, ju-j, -cone, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), &
ldab-1, ab( kv+1, j+1 ),ldab-1 )
end if
else
! if pivot is czero, set info to the index of the pivot
! unless a czero pivot has already been found.
if( info==0_${ik}$ )info = j
end if
end do loop_40
return
end subroutine stdlib${ii}$_${ci}$gbtf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! SGBTRS solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general band matrix A using the LU factorization computed
!! by SGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-one modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_sswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_sger( lm, nrhs, -one, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, 1_${ik}$ )&
, ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else
! solve a**t*x = b.
do i = 1, nrhs
! solve u**t*x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t*x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_sgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j )&
, 1_${ik}$, one, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_sswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_sgbtrs
pure module subroutine stdlib${ii}$_dgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! DGBTRS solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general band matrix A using the LU factorization computed
!! by DGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-one modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_dswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_dger( lm, nrhs, -one, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, 1_${ik}$ )&
, ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else
! solve a**t*x = b.
do i = 1, nrhs
! solve u**t*x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t*x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_dgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j )&
, 1_${ik}$, one, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_dswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_dgbtrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! DGBTRS: solves a system of linear equations
!! A * X = B or A**T * X = B
!! with a general band matrix A using the LU factorization computed
!! by DGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-one modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_${ri}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ri}$ger( lm, nrhs, -one, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, 1_${ik}$ )&
, ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else
! solve a**t*x = b.
do i = 1, nrhs
! solve u**t*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t*x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j )&
, 1_${ik}$, one, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_${ri}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$gbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! CGBTRS solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general band matrix A using the LU factorization computed
!! by CGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: ab(ldab,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-cone modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( lm, nrhs, -cone, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, &
1_${ik}$ ), ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b.
do i = 1, nrhs
! solve u**t * x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_cgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j &
), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
else
! solve a**h * x = b.
do i = 1, nrhs
! solve u**h * x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,&
b( 1_${ik}$, i ), 1_${ik}$ )
end do
! solve l**h * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_clacgv( nrhs, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, &
ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_cgbtrs
pure module subroutine stdlib${ii}$_zgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! ZGBTRS solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general band matrix A using the LU factorization computed
!! by ZGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: ab(ldab,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-cone modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( lm, nrhs, -cone, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, &
1_${ik}$ ), ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b.
do i = 1, nrhs
! solve u**t * x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_zgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j &
), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
else
! solve a**h * x = b.
do i = 1, nrhs
! solve u**h * x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,&
b( 1_${ik}$, i ), 1_${ik}$ )
end do
! solve l**h * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_zlacgv( nrhs, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, &
ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_zgbtrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info )
!! ZGBTRS: solves a system of linear equations
!! A * X = B, A**T * X = B, or A**H * X = B
!! with a general band matrix A using the LU factorization computed
!! by ZGBTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lnoti, notran
integer(${ik}$) :: i, j, kd, l, lm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<( 2_${ik}$*kl+ku+1 ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
kd = ku + kl + 1_${ik}$
lnoti = kl>0_${ik}$
if( notran ) then
! solve a*x = b.
! solve l*x = b, overwriting b with x.
! l is represented as a product of permutations and unit lower
! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1),
! where each transformation l(i) is a rank-cone modification of
! the identity matrix.
if( lnoti ) then
do j = 1, n - 1
lm = min( kl, n-j )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( lm, nrhs, -cone, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, &
1_${ik}$ ), ldb )
end do
end if
do i = 1, nrhs
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, &
i ), 1_${ik}$ )
end do
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b.
do i = 1, nrhs
! solve u**t * x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )&
, 1_${ik}$ )
end do
! solve l**t * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j &
), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
else
! solve a**h * x = b.
do i = 1, nrhs
! solve u**h * x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,&
b( 1_${ik}$, i ), 1_${ik}$ )
end do
! solve l**h * x = b, overwriting b with x.
if( lnoti ) then
do j = n - 1, 1, -1
lm = min( kl, n-j )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, &
ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( j, 1_${ik}$ ), ldb )
l = ipiv( j )
if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$gbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! SGBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_sgbmv( trans, n, n, kl, ku, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,one, work( n+1 &
), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = abs( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
work( i ) = work( i ) + abs( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + abs( ab( kk+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_sgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_sgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_sgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_sgbrfs
pure module subroutine stdlib${ii}$_dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! DGBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dgbmv( trans, n, n, kl, ku, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,one, work( n+1 &
), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = abs( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
work( i ) = work( i ) + abs( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + abs( ab( kk+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_dgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_dgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dgbrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! DGBRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transt = 'T'
else
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gbmv( trans, n, n, kl, ku, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,one, work( n+1 &
), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = abs( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
work( i ) = work( i ) + abs( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + abs( ab( kk+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_${ri}$gbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, &
info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$gbrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! CGBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_cgbmv( trans, n, n, kl, ku, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,cone, work, 1_${ik}$ &
)
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = cabs1( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
rwork( i ) = rwork( i ) + cabs1( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + cabs1( ab( kk+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_cgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cgbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cgbrfs
pure module subroutine stdlib${ii}$_zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! ZGBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zgbmv( trans, n, n, kl, ku, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,cone, work, 1_${ik}$ &
)
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = cabs1( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
rwork( i ) = rwork( i ) + cabs1( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + cabs1( ab( kk+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_zgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zgbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zgbrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, &
!! ZGBRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is banded, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, k, kase, kk, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kl+ku+1 ) then
info = -7_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -9_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( kl+ku+2, n+1 )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$gbmv( trans, n, n, kl, ku, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$,cone, work, 1_${ik}$ &
)
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(op(a))*abs(x) + abs(b).
if( notran ) then
do k = 1, n
kk = ku + 1_${ik}$ - k
xk = cabs1( x( k, j ) )
do i = max( 1, k-ku ), min( n, k+kl )
rwork( i ) = rwork( i ) + cabs1( ab( kk+i, k ) )*xk
end do
end do
else
do k = 1, n
s = zero
kk = ku + 1_${ik}$ - k
do i = max( 1, k-ku ), min( n, k+kl )
s = s + cabs1( ab( kk+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_${ci}$gbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$gbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$gbrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! SGBEQU computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_sgbequ
pure module subroutine stdlib${ii}$_dgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! DGBEQU computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_dgbequ
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! DGBEQU: computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${rk}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${rk}$) :: bignum, rcmax, rcmin, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ri}$gbequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! CGBEQU computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(out) :: c(*), r(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: bignum, rcmax, rcmin, smlnum
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_cgbequ
pure module subroutine stdlib${ii}$_zgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! ZGBEQU computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(out) :: c(*), r(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: bignum, rcmax, rcmin, smlnum
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_zgbequ
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! ZGBEQU: computes row and column scalings intended to equilibrate an
!! M-by-N band matrix A and reduce its condition number. R returns the
!! row scale factors and C the column scale factors, chosen to try to
!! make the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!! R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!! number and BIGNUM = largest safe number. Use of these scaling
!! factors is not guaranteed to reduce the condition number of A but
!! works well in practice.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${ck}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(out) :: c(*), r(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${ck}$) :: bignum, rcmax, rcmin, smlnum
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBEQU', -info )
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i))
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j))
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ci}$gbequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! SGBEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from SGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_slamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_sgbequb
pure module subroutine stdlib${ii}$_dgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! DGBEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from DGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_dlamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_dgbequb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! DGBEQUB: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from DGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${rk}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: c(*), r(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${rk}$) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_${ri}$lamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), abs( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ri}$gbequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! CGBEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from CGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(out) :: c(*), r(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_slamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_cgbequb
pure module subroutine stdlib${ii}$_zgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! ZGBEQUB computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from ZGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(out) :: c(*), r(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_dlamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_zgbequb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info )
!! ZGBEQUB: computes row and column scalings intended to equilibrate an
!! M-by-N matrix A and reduce its condition number. R returns the row
!! scale factors and C the column scale factors, chosen to try to make
!! the largest element in each row and column of the matrix B with
!! elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!! the radix.
!! R(i) and C(j) are restricted to be a power of the radix between
!! SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
!! of these scaling factors is not guaranteed to reduce the condition
!! number of A but works well in practice.
!! This routine differs from ZGEEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled entries' magnitudes are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${ck}$), intent(out) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(out) :: c(*), r(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${ck}$) :: bignum, rcmax, rcmin, smlnum, radix, logrdx
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( m<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ ) then
info = -3_${ik}$
else if( ku<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGBEQUB', -info )
return
end if
! quick return if possible.
if( m==0_${ik}$ .or. n==0_${ik}$ ) then
rowcnd = one
colcnd = one
amax = zero
return
end if
! get machine constants. assume smlnum is a power of the radix.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
radix = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
logrdx = log(radix)
! compute row scale factors.
do i = 1, m
r( i ) = zero
end do
! find the maximum element in each row.
kd = ku + 1_${ik}$
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
r( i ) = max( r( i ), cabs1( ab( kd+i-j, j ) ) )
end do
end do
do i = 1, m
if( r( i )>zero ) then
r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do i = 1, m
rcmax = max( rcmax, r( i ) )
rcmin = min( rcmin, r( i ) )
end do
amax = rcmax
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do i = 1, m
if( r( i )==zero ) then
info = i
return
end if
end do
else
! invert the scale factors.
do i = 1, m
r( i ) = one / min( max( r( i ), smlnum ), bignum )
end do
! compute rowcnd = min(r(i)) / max(r(i)).
rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
! compute column scale factors.
do j = 1, n
c( j ) = zero
end do
! find the maximum element in each column,
! assuming the row scaling computed above.
do j = 1, n
do i = max( j-ku, 1 ), min( j+kl, m )
c( j ) = max( c( j ), cabs1( ab( kd+i-j, j ) )*r( i ) )
end do
if( c( j )>zero ) then
c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$)
end if
end do
! find the maximum and minimum scale factors.
rcmin = bignum
rcmax = zero
do j = 1, n
rcmin = min( rcmin, c( j ) )
rcmax = max( rcmax, c( j ) )
end do
if( rcmin==zero ) then
! find the first zero scale factor and return an error code.
do j = 1, n
if( c( j )==zero ) then
info = m + j
return
end if
end do
else
! invert the scale factors.
do j = 1, n
c( j ) = one / min( max( c( j ), smlnum ), bignum )
end do
! compute colcnd = min(c(j)) / max(c(j)).
colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
end if
return
end subroutine stdlib${ii}$_${ci}$gbequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! SLAQGB equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(inout) :: ab(ldab,*)
real(sp), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_slaqgb
pure module subroutine stdlib${ii}$_dlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! DLAQGB equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(inout) :: ab(ldab,*)
real(dp), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_dlaqgb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! DLAQGB: equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${rk}$), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(${rk}$), intent(inout) :: ab(ldab,*)
real(${rk}$), intent(in) :: c(*), r(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_${ri}$laqgb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! CLAQGB equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(sp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(sp), intent(in) :: c(*), r(*)
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_claqgb
pure module subroutine stdlib${ii}$_zlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! ZLAQGB equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(dp), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(dp), intent(in) :: c(*), r(*)
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_zlaqgb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed )
!! ZLAQGB: equilibrates a general M by N band matrix A with KL
!! subdiagonals and KU superdiagonals using the row and scaling factors
!! in the vectors R and C.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
integer(${ik}$), intent(in) :: kl, ku, ldab, m, n
real(${ck}$), intent(in) :: amax, colcnd, rowcnd
! Array Arguments
real(${ck}$), intent(in) :: c(*), r(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then
! no row scaling
if( colcnd>=thresh ) then
! no column scaling
equed = 'N'
else
! column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j )
end do
end do
equed = 'C'
end if
else if( colcnd>=thresh ) then
! row scaling, no column scaling
do j = 1, n
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'R'
else
! row and column scaling
do j = 1, n
cj = c( j )
do i = max( 1, j-ku ), min( m, j+kl )
ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j )
end do
end do
equed = 'B'
end if
return
end subroutine stdlib${ii}$_${ci}$laqgb
#:endif
#:endfor
real(sp) module function stdlib${ii}$_sla_gbrcond( trans, n, kl, ku, ab, ldab, afb, ldafb,ipiv, cmode, c, &
!! SLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
info, work, iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, ldab, ldafb, kl, ku, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j, kd, ke
real(sp) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_sla_gbrcond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ .or. kl>n-1 ) then
info = -3_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLA_GBRCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_sla_gbrcond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
if ( notrans ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if ( notrans ) then
call stdlib${ii}$_sgbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
else
call stdlib${ii}$_sgbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( notrans ) then
call stdlib${ii}$_sgbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
else
call stdlib${ii}$_sgbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= 0.0_sp )stdlib${ii}$_sla_gbrcond = ( one / ainvnm )
return
end function stdlib${ii}$_sla_gbrcond
real(dp) module function stdlib${ii}$_dla_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,&
!! DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
info, work, iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, ldab, ldafb, kl, ku, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j, kd, ke
real(dp) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_dla_gbrcond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ .or. kl>n-1 ) then
info = -3_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_GBRCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_dla_gbrcond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
if ( notrans ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if ( notrans ) then
call stdlib${ii}$_dgbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
else
call stdlib${ii}$_dgbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( notrans ) then
call stdlib${ii}$_dgbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
else
call stdlib${ii}$_dgbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_dla_gbrcond = ( one / ainvnm )
return
end function stdlib${ii}$_dla_gbrcond
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$la_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,&
!! DLA_GBRCOND: Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
info, work, iwork )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(in) :: n, ldab, ldafb, kl, ku, cmode
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notrans
integer(${ik}$) :: kase, i, j, kd, ke
real(${rk}$) :: ainvnm, tmp
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_${ri}$la_gbrcond = zero
info = 0_${ik}$
notrans = stdlib_lsame( trans, 'N' )
if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, &
'C') ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kl<0_${ik}$ .or. kl>n-1 ) then
info = -3_${ik}$
else if( ku<0_${ik}$ .or. ku>n-1 ) then
info = -4_${ik}$
else if( ldab<kl+ku+1 ) then
info = -6_${ik}$
else if( ldafb<2_${ik}$*kl+ku+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_GBRCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_${ri}$la_gbrcond = one
return
end if
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
kd = ku + 1_${ik}$
ke = kl + 1_${ik}$
if ( notrans ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( kd+i-j, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) )
end do
else
do j = max( i-kl, 1 ), min( i+ku, n )
tmp = tmp + abs( ab( ke-i+j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
end if
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if ( notrans ) then
call stdlib${ii}$_${ri}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
else
call stdlib${ii}$_${ri}$gbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
end if
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( notrans ) then
call stdlib${ii}$_${ri}$gbtrs( 'TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info &
)
else
call stdlib${ii}$_${ri}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1_${ik}$, afb, ldafb,ipiv, work, n, &
info )
end if
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_${ri}$la_gbrcond = ( one / ainvnm )
return
end function stdlib${ii}$_${ri}$la_gbrcond
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb )
!! SLA_GBRPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: amax, umax, rpvgrw
! Intrinsic Functions
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( abs( ab( kd+i-j, j)), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( abs( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_sla_gbrpvgrw = rpvgrw
end function stdlib${ii}$_sla_gbrpvgrw
pure real(dp) module function stdlib${ii}$_dla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb )
!! DLA_GBRPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
real(dp), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: amax, umax, rpvgrw
! Intrinsic Functions
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( abs( ab( kd+i-j, j)), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( abs( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_dla_gbrpvgrw = rpvgrw
end function stdlib${ii}$_dla_gbrpvgrw
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$la_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb )
!! DLA_GBRPVGRW: computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${rk}$) :: amax, umax, rpvgrw
! Intrinsic Functions
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( abs( ab( kd+i-j, j)), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( abs( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_${ri}$la_gbrpvgrw = rpvgrw
end function stdlib${ii}$_${ri}$la_gbrpvgrw
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_cla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb )
!! CLA_GBRPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
complex(sp), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(sp) :: amax, umax, rpvgrw
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( cabs1( ab( kd+i-j, j ) ), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( cabs1( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_cla_gbrpvgrw = rpvgrw
end function stdlib${ii}$_cla_gbrpvgrw
pure real(dp) module function stdlib${ii}$_zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb )
!! ZLA_GBRPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
complex(dp), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(dp) :: amax, umax, rpvgrw
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( cabs1( ab( kd+i-j, j ) ), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( cabs1( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_zla_gbrpvgrw = rpvgrw
end function stdlib${ii}$_zla_gbrpvgrw
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure real(${ck}$) module function stdlib${ii}$_${ci}$la_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb )
!! ZLA_GBRPVGRW: computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb
! Array Arguments
complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, kd
real(${ck}$) :: amax, umax, rpvgrw
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
rpvgrw = one
kd = ku + 1_${ik}$
do j = 1, ncols
amax = zero
umax = zero
do i = max( j-ku, 1 ), min( j+kl, n )
amax = max( cabs1( ab( kd+i-j, j ) ), amax )
end do
do i = max( j-ku, 1 ), j
umax = max( cabs1( afb( kd+i-j, j ) ), umax )
end do
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
stdlib${ii}$_${ci}$la_gbrpvgrw = rpvgrw
end function stdlib${ii}$_${ci}$la_gbrpvgrw
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info &
!! SGTCON estimates the reciprocal of the condition number of a real
!! tridiagonal matrix A using the LU factorization as computed by
!! SGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==zero )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_sgttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**t)*inv(u**t).
call stdlib${ii}$_sgttrs( 'TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv, work,n, info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_sgtcon
pure module subroutine stdlib${ii}$_dgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info &
!! DGTCON estimates the reciprocal of the condition number of a real
!! tridiagonal matrix A using the LU factorization as computed by
!! DGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==zero )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_dgttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**t)*inv(u**t).
call stdlib${ii}$_dgttrs( 'TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv, work,n, info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_dgtcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info &
!! DGTCON: estimates the reciprocal of the condition number of a real
!! tridiagonal matrix A using the LU factorization as computed by
!! DGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(${rk}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==zero )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_${ri}$gttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**t)*inv(u**t).
call stdlib${ii}$_${ri}$gttrs( 'TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv, work,n, info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ri}$gtcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info )
!! CGTCON estimates the reciprocal of the condition number of a complex
!! tridiagonal matrix A using the LU factorization as computed by
!! CGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==cmplx( zero,KIND=sp) )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_cgttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**h)*inv(u**h).
call stdlib${ii}$_cgttrs( 'CONJUGATE TRANSPOSE', n, 1_${ik}$, dl, d, du, du2,ipiv, work, n, &
info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_cgtcon
pure module subroutine stdlib${ii}$_zgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info )
!! ZGTCON estimates the reciprocal of the condition number of a complex
!! tridiagonal matrix A using the LU factorization as computed by
!! ZGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==cmplx( zero,KIND=dp) )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_zgttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**h)*inv(u**h).
call stdlib${ii}$_zgttrs( 'CONJUGATE TRANSPOSE', n, 1_${ik}$, dl, d, du, du2,ipiv, work, n, &
info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zgtcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info )
!! ZGTCON: estimates the reciprocal of the condition number of a complex
!! tridiagonal matrix A using the LU factorization as computed by
!! ZGTTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: norm
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: onenrm
integer(${ik}$) :: i, kase, kase1
real(${ck}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is non-zero.
do i = 1, n
if( d( i )==cmplx( zero,KIND=${ck}$) )return
end do
ainvnm = zero
if( onenrm ) then
kase1 = 1_${ik}$
else
kase1 = 2_${ik}$
end if
kase = 0_${ik}$
20 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==kase1 ) then
! multiply by inv(u)*inv(l).
call stdlib${ii}$_${ci}$gttrs( 'NO TRANSPOSE', n, 1_${ik}$, dl, d, du, du2, ipiv,work, n, info )
else
! multiply by inv(l**h)*inv(u**h).
call stdlib${ii}$_${ci}$gttrs( 'CONJUGATE TRANSPOSE', n, 1_${ik}$, dl, d, du, du2,ipiv, work, n, &
info )
end if
go to 20
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$gtcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgttrf( n, dl, d, du, du2, ipiv, info )
!! SGTTRF computes an LU factorization of a real tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: d(*), dl(*), du(*)
real(sp), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: fact, temp
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'SGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( abs( d( i ) )>=abs( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( abs( d( i ) )>=abs( dl( i ) ) ) then
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( d( i )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_sgttrf
pure module subroutine stdlib${ii}$_dgttrf( n, dl, d, du, du2, ipiv, info )
!! DGTTRF computes an LU factorization of a real tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: d(*), dl(*), du(*)
real(dp), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: fact, temp
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( abs( d( i ) )>=abs( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( abs( d( i ) )>=abs( dl( i ) ) ) then
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( d( i )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_dgttrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gttrf( n, dl, d, du, du2, ipiv, info )
!! DGTTRF: computes an LU factorization of a real tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: d(*), dl(*), du(*)
real(${rk}$), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: fact, temp
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( abs( d( i ) )>=abs( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( abs( d( i ) )>=abs( dl( i ) ) ) then
if( d( i )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( d( i )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_${ri}$gttrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgttrf( n, dl, d, du, du2, ipiv, info )
!! CGTTRF computes an LU factorization of a complex tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: d(*), dl(*), du(*)
complex(sp), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(sp) :: fact, temp, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'CGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( cabs1( d( i ) )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_cgttrf
pure module subroutine stdlib${ii}$_zgttrf( n, dl, d, du, du2, ipiv, info )
!! ZGTTRF computes an LU factorization of a complex tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: d(*), dl(*), du(*)
complex(dp), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(dp) :: fact, temp, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'ZGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( cabs1( d( i ) )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_zgttrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gttrf( n, dl, d, du, du2, ipiv, info )
!! ZGTTRF: computes an LU factorization of a complex tridiagonal matrix A
!! using elimination with partial pivoting and row interchanges.
!! The factorization has the form
!! A = L * U
!! where L is a product of permutation and unit lower bidiagonal
!! matrices and U is upper triangular with nonzeros in only the main
!! diagonal and first two superdiagonals.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: d(*), dl(*), du(*)
complex(${ck}$), intent(out) :: du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
complex(${ck}$) :: fact, temp, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'ZGTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize ipiv(i) = i and du2(i) = 0
do i = 1, n
ipiv( i ) = i
end do
do i = 1, n - 2
du2( i ) = zero
end do
do i = 1, n - 2
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
! no row interchange required, eliminate dl(i)
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
! interchange rows i and i+1, eliminate dl(i)
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
du2( i ) = du( i+1 )
du( i+1 ) = -fact*du( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end do
if( n>1_${ik}$ ) then
i = n - 1_${ik}$
if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then
if( cabs1( d( i ) )/=zero ) then
fact = dl( i ) / d( i )
dl( i ) = fact
d( i+1 ) = d( i+1 ) - fact*du( i )
end if
else
fact = d( i ) / dl( i )
d( i ) = dl( i )
dl( i ) = fact
temp = du( i )
du( i ) = d( i+1 )
d( i+1 ) = temp - fact*d( i+1 )
ipiv( i ) = i + 1_${ik}$
end if
end if
! check for a zero on the diagonal of u.
do i = 1, n
if( cabs1( d( i ) )==zero ) then
info = i
go to 50
end if
end do
50 continue
return
end subroutine stdlib${ii}$_${ci}$gttrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! SGTTRS solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by SGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: b(ldb,*)
real(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else
itrans = 1_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'SGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_sgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_sgttrs
pure module subroutine stdlib${ii}$_dgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! DGTTRS solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by DGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: b(ldb,*)
real(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else
itrans = 1_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_dgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_dgttrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! DGTTRS: solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by DGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: b(ldb,*)
real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else
itrans = 1_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_${ri}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_${ri}$gttrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! CGTTRS solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by CGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: b(ldb,*)
complex(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else if( trans=='T' .or. trans=='T' ) then
itrans = 1_${ik}$
else
itrans = 2_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'CGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_cgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_cgttrs
pure module subroutine stdlib${ii}$_zgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! ZGTTRS solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by ZGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: b(ldb,*)
complex(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else if( trans=='T' .or. trans=='T' ) then
itrans = 1_${ik}$
else
itrans = 2_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_zgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_zgttrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info )
!! ZGTTRS: solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by ZGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran
integer(${ik}$) :: itrans, j, jb, nb
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
notran = ( trans=='N' .or. trans=='N' )
if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. &
trans=='C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( n, 1_${ik}$ ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! decode trans
if( notran ) then
itrans = 0_${ik}$
else if( trans=='T' .or. trans=='T' ) then
itrans = 1_${ik}$
else
itrans = 2_${ik}$
end if
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGTTRS', trans, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_${ci}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb )
end do
end if
end subroutine stdlib${ii}$_${ci}$gttrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! SGTTS2 solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by SGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(inout) :: b(ldb,*)
real(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, j
real(sp) :: temp
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
ip = ipiv( i )
temp = b( i+1-ip+i, j ) - dl( i )*b( ip, j )
b( i, j ) = b( ip, j )
b( i+1, j ) = temp
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
! solve u**t*x = b.
j = 1_${ik}$
70 continue
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t*x = b.
do i = n - 1, 1, -1
ip = ipiv( i )
temp = b( i, j ) - dl( i )*b( i+1, j )
b( i, j ) = b( ip, j )
b( ip, j ) = temp
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t*x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_sgtts2
pure module subroutine stdlib${ii}$_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! DGTTS2 solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by DGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(inout) :: b(ldb,*)
real(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, j
real(dp) :: temp
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
ip = ipiv( i )
temp = b( i+1-ip+i, j ) - dl( i )*b( ip, j )
b( i, j ) = b( ip, j )
b( i+1, j ) = temp
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
! solve u**t*x = b.
j = 1_${ik}$
70 continue
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t*x = b.
do i = n - 1, 1, -1
ip = ipiv( i )
temp = b( i, j ) - dl( i )*b( i+1, j )
b( i, j ) = b( ip, j )
b( ip, j ) = temp
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t*x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_dgtts2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! DGTTS2: solves one of the systems of equations
!! A*X = B or A**T*X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by DGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${rk}$), intent(inout) :: b(ldb,*)
real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ip, j
real(${rk}$) :: temp
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
ip = ipiv( i )
temp = b( i+1-ip+i, j ) - dl( i )*b( ip, j )
b( i, j ) = b( ip, j )
b( i+1, j ) = temp
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
! solve u**t*x = b.
j = 1_${ik}$
70 continue
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t*x = b.
do i = n - 1, 1, -1
ip = ipiv( i )
temp = b( i, j ) - dl( i )*b( i+1, j )
b( i, j ) = b( ip, j )
b( ip, j ) = temp
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t*x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_${ri}$gtts2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! CGTTS2 solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by CGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: b(ldb,*)
complex(sp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
complex(sp) :: temp
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else if( itrans==1_${ik}$ ) then
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
70 continue
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
else
! solve a**h * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
130 continue
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( &
i-2, j ) ) /conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 130
end if
else
do j = 1, nrhs
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )&
*b( i-2, j ) ) / conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_cgtts2
pure module subroutine stdlib${ii}$_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! ZGTTS2 solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by ZGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: b(ldb,*)
complex(dp), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
complex(dp) :: temp
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else if( itrans==1_${ik}$ ) then
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
70 continue
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
else
! solve a**h * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
130 continue
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( &
i-2, j ) ) /conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 130
end if
else
do j = 1, nrhs
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) )/ conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )&
*b( i-2, j ) ) / conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_zgtts2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb )
!! ZGTTS2: solves one of the systems of equations
!! A * X = B, A**T * X = B, or A**H * X = B,
!! with a tridiagonal matrix A using the LU factorization computed
!! by ZGTTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
complex(${ck}$) :: temp
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( itrans==0_${ik}$ ) then
! solve a*x = b using the lu factorization of a,
! overwriting each right hand side vector with its solution.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve l*x = b.
do i = 1, n - 1
if( ipiv( i )==i ) then
b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j )
else
temp = b( i, j )
b( i, j ) = b( i+1, j )
b( i+1, j ) = temp - dl( i )*b( i, j )
end if
end do
! solve u*x = b.
b( n, j ) = b( n, j ) / d( n )
if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 )
do i = n - 2, 1, -1
b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i )
end do
end do
end if
else if( itrans==1_${ik}$ ) then
! solve a**t * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
70 continue
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i &
)
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 70
end if
else
do j = 1, nrhs
! solve u**t * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ )
do i = 3, n
b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(&
i )
end do
! solve l**t * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - dl( i )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - dl( i )*temp
b( i, j ) = temp
end if
end do
end do
end if
else
! solve a**h * x = b.
if( nrhs<=1_${ik}$ ) then
j = 1_${ik}$
130 continue
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( &
i-2, j ) ) /conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 130
end if
else
do j = 1, nrhs
! solve u**h * x = b.
b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) )
if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) )/ conjg( d( 2_${ik}$ ) )
do i = 3, n
b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )&
*b( i-2, j ) ) / conjg( d( i ) )
end do
! solve l**h * x = b.
do i = n - 1, 1, -1
if( ipiv( i )==i ) then
b( i, j ) = b( i, j ) - conjg( dl( i ) )*b( i+1, j )
else
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - conjg( dl( i ) )*temp
b( i, j ) = temp
end if
end do
end do
end if
end if
end subroutine stdlib${ii}$_${ci}$gtts2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! SGTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'T'
else
transn = 'T'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_slagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work( n+1 ), &
n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( du( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( dl( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( du( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( dl( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
else
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( dl( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( du( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( dl( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( du( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_sgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_sgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_sgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_sgtrfs
pure module subroutine stdlib${ii}$_dgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! DGTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'T'
else
transn = 'T'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dlagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work( n+1 ), &
n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( du( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( dl( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( du( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( dl( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
else
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( dl( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( du( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( dl( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( du( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_dgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_dgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_dgtrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! DGTRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'T'
else
transn = 'T'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work( n+1 ), &
n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( du( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( dl( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( du( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( dl( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
else
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) )
else
work( 1_${ik}$ ) = abs( b( 1_${ik}$, j ) ) + abs( d( 1_${ik}$ )*x( 1_${ik}$, j ) ) +abs( dl( 1_${ik}$ )*x( 2_${ik}$, j )&
)
do i = 2, n - 1
work( i ) = abs( b( i, j ) ) +abs( du( i-1 )*x( i-1, j ) ) +abs( d( i )*x( &
i, j ) ) +abs( dl( i )*x( i+1, j ) )
end do
work( n ) = abs( b( n, j ) ) +abs( du( n-1 )*x( n-1, j ) ) +abs( d( n )*x( n, &
j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$gttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**t).
call stdlib${ii}$_${ri}$gttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_${ri}$gttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, &
info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_${ri}$gtrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! CGTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_clagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work, n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
du( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( dl( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( du( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( dl( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
else
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
dl( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( du( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( dl( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( du( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info )
call stdlib${ii}$_caxpy( n, cmplx( one,KIND=sp), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_cgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_cgtrfs
pure module subroutine stdlib${ii}$_zgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! ZGTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zlagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work, n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
du( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( dl( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( du( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( dl( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
else
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
dl( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( du( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( dl( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( du( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info )
call stdlib${ii}$_zaxpy( n, cmplx( one,KIND=dp), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_zgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_zgtrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, &
!! ZGTRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is tridiagonal, and provides
!! error bounds and backward error estimates for the solution.
ldx, ferr, berr, work, rwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: notran
character :: transn, transt
integer(${ik}$) :: count, i, j, kase, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
notran = stdlib_lsame( trans, 'N' )
if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, &
'C' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGTRFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
if( notran ) then
transn = 'N'
transt = 'C'
else
transn = 'C'
transt = 'N'
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_110: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$lagtm( trans, n, 1_${ik}$, -one, dl, d, du, x( 1_${ik}$, j ), ldx, one,work, n )
! compute abs(op(a))*abs(x) + abs(b) for use in the backward
! error bound.
if( notran ) then
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
du( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( dl( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( du( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( dl( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
else
if( n==1_${ik}$ ) then
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) )
else
rwork( 1_${ik}$ ) = cabs1( b( 1_${ik}$, j ) ) +cabs1( d( 1_${ik}$ ) )*cabs1( x( 1_${ik}$, j ) ) +cabs1( &
dl( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
rwork( i ) = cabs1( b( i, j ) ) +cabs1( du( i-1 ) )*cabs1( x( i-1, j ) ) +&
cabs1( d( i ) )*cabs1( x( i, j ) ) +cabs1( dl( i ) )*cabs1( x( i+1, j ) )
end do
rwork( n ) = cabs1( b( n, j ) ) +cabs1( du( n-1 ) )*cabs1( x( n-1, j ) ) +&
cabs1( d( n ) )*cabs1( x( n, j ) )
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$gttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info )
call stdlib${ii}$_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(op(a)))*
! ( abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(op(a)) is the inverse of op(a)
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(op(a))*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(op(a)) * diag(w),
! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
70 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(op(a)**h).
call stdlib${ii}$_${ci}$gttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else
! multiply by inv(op(a))*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$gttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info )
end if
go to 70
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_110
return
end subroutine stdlib${ii}$_${ci}$gtrfs
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_lu_comp
