#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_tri_comp
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_strcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info )
!! STRCON estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=sp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_slantr( norm, uplo, diag, n, n, a, lda, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_slatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_slatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, &
work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_strcon
module subroutine stdlib${ii}$_dtrcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info )
!! DTRCON estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=dp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_dlantr( norm, uplo, diag, n, n, a, lda, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_dlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_dlatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, &
work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_dtrcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$trcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info )
!! DTRCON: estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${rk}$) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=${rk}$)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_${ri}$lantr( norm, uplo, diag, n, n, a, lda, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_${ri}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_${ri}$latrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, &
work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ri}$trcon
#:endif
#:endfor
module subroutine stdlib${ii}$_ctrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info )
!! CTRCON estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=sp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_clantr( norm, uplo, diag, n, n, a, lda, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_clatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_clatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,&
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ctrcon
module subroutine stdlib${ii}$_ztrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info )
!! ZTRCON estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=dp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_zlantr( norm, uplo, diag, n, n, a, lda, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_zlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_zlatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,&
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ztrcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$trcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info )
!! ZTRCON: estimates the reciprocal of the condition number of a
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${ck}$) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=${ck}$)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_${ci}$lantr( norm, uplo, diag, n, n, a, lda, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_${ci}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,&
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_${ci}$latrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,&
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ci}$trcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! STRTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
call stdlib${ii}$_strsm( 'LEFT', uplo, trans, diag, n, nrhs, one, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_strtrs
pure module subroutine stdlib${ii}$_dtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! DTRTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, diag, n, nrhs, one, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_dtrtrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! DTRTRS: solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
call stdlib${ii}$_${ri}$trsm( 'LEFT', uplo, trans, diag, n, nrhs, one, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_${ri}$trtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! CTRTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, diag, n, nrhs, cone, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_ctrtrs
pure module subroutine stdlib${ii}$_ztrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! ZTRTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, diag, n, nrhs, cone, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_ztrtrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info )
!! ZTRTRS: solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N, and B is an N-by-NRHS
!! matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, diag, n, nrhs, cone, a, lda, b,ldb )
return
end subroutine stdlib${ii}$_${ci}$trtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! SLATRS solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, x and b are
!! n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine STRSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_sasum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_sasum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_strsv can be used.
j = stdlib${ii}$_isamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( a( j, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( a( j, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_strsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_100: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 95
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
95 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_saxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_saxpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_isamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end if
end do loop_100
else
! solve a**t * x = b
loop_140: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_sdot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_sdot( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_sdot( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 135
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
135 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_140
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_slatrs
pure module subroutine stdlib${ii}$_dlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! DLATRS solves one of the triangular systems
!! A *x = s*b or A**T *x = s*b
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, x and b are
!! n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(dp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_dasum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_dasum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_dtrsv can be used.
j = stdlib${ii}$_idamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( a( j, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( a( j, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_dtrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_daxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_daxpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_idamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end if
end do loop_110
else
! solve a**t * x = b
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_ddot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_ddot( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_ddot( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dlatrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$latrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! DLATRS: solves one of the triangular systems
!! A *x = s*b or A**T *x = s*b
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, x and b are
!! n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(out) :: scale
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(${rk}$) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_${ri}$asum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_${ri}$asum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_i${ri}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_${ri}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ri}$trsv can be used.
j = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( a( j, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( a( j, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ri}$trsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_${ri}$scal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ri}$scal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_${ri}$axpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_i${ri}$amax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_${ri}$axpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_i${ri}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end if
end do loop_110
else
! solve a**t * x = b
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ri}$dot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_${ri}$dot( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_${ri}$dot( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
sumj = sumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${ri}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$latrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! CLATRS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, A**H denotes the
!! conjugate transpose of A, x and b are n-element vectors, and s is a
!! scaling factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(inout) :: cnorm(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(sp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(sp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=sp) / 2. ) +abs( aimag( zdum ) / 2. )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_scasum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_scasum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ctrsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ctrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 105
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
105 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_csscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_caxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_caxpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_icamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end if
end do loop_110
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_150: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_cdotu( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_cdotu( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 145
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
145 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_150
else
! solve a**h * x = b
loop_190: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_cdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_cdotc( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 185
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
185 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_190
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_clatrs
pure module subroutine stdlib${ii}$_zlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! ZLATRS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, A**H denotes the
!! conjugate transpose of A, x and b are n-element vectors, and s is a
!! scaling factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(inout) :: cnorm(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(dp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(dp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=dp) / 2._dp ) +abs( aimag( zdum ) / 2._dp )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_dzasum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_dzasum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ztrsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ztrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_zdscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_zaxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_zaxpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_izamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_zdotu( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_zdotu( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_170
else
! solve a**h * x = b
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_zdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_zdotc( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zlatrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$latrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info )
!! ZLATRS: solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow. Here A is an upper or lower
!! triangular matrix, A**T denotes the transpose of A, A**H denotes the
!! conjugate transpose of A, x and b are n-element vectors, and s is a
!! scaling factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: scale
! Array Arguments
real(${ck}$), intent(inout) :: cnorm(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast
real(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(${ck}$) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( n-j, a( j+1, j ), 1_${ik}$ )
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_${c2ri(ci)}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ci}$trsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = a( j, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ci}$trsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ci}$dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_${ci}$axpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_${ci}$axpy( n-j, -x( j )*tscal, a( j+1, j ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_i${ci}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_${ci}$dotu( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_${ci}$dotu( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( a( i, j )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = a( j, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_170
else
! solve a**h * x = b
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_${ci}$dotc( j-1, a( 1_${ik}$, j ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_${ci}$dotc( n-j, a( j+1, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = j + 1, n
csumj = csumj + ( conjg( a( i, j ) )*uscal )*x( i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = conjg( a( j, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$latrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strtri( uplo, diag, n, a, lda, info )
!! STRTRI computes the inverse of a real upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'STRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_strti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_strmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,&
a( 1_${ik}$, j ), lda )
call stdlib${ii}$_strsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,&
j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_strti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_strmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,&
a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_strti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_strtri
pure module subroutine stdlib${ii}$_dtrtri( uplo, diag, n, a, lda, info )
!! DTRTRI computes the inverse of a real upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_dtrti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_dtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,&
a( 1_${ik}$, j ), lda )
call stdlib${ii}$_dtrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,&
j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_dtrti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_dtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,&
a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_dtrti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_dtrtri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trtri( uplo, diag, n, a, lda, info )
!! DTRTRI: computes the inverse of a real upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==zero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ri}$trti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_${ri}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,&
a( 1_${ik}$, j ), lda )
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,&
j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_${ri}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_${ri}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,&
a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_${ri}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$trtri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrtri( uplo, diag, n, a, lda, info )
!! CTRTRI computes the inverse of a complex upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_ctrti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_ctrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, &
lda, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_ctrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( &
j, j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_ctrti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, &
cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
cone, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_ctrti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_ctrtri
pure module subroutine stdlib${ii}$_ztrtri( uplo, diag, n, a, lda, info )
!! ZTRTRI computes the inverse of a complex upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_ztrti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_ztrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, &
lda, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_ztrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( &
j, j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_ztrti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, &
cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
cone, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_ztrti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_ztrtri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trtri( uplo, diag, n, a, lda, info )
!! ZTRTRI: computes the inverse of a complex upper or lower triangular
!! matrix A.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jb, nb, nn
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity if non-unit.
if( nounit ) then
do info = 1, n
if( a( info, info )==czero )return
end do
info = 0_${ik}$
end if
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ci}$trti2( uplo, diag, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute inverse of upper triangular matrix
do j = 1, n, nb
jb = min( nb, n-j+1 )
! compute rows 1:j-1 of current block column
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, &
lda, a( 1_${ik}$, j ), lda )
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( &
j, j ), lda, a( 1_${ik}$, j ), lda )
! compute inverse of current diagonal block
call stdlib${ii}$_${ci}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info )
end do
else
! compute inverse of lower triangular matrix
nn = ( ( n-1 ) / nb )*nb + 1_${ik}$
do j = nn, 1, -nb
jb = min( nb, n-j+1 )
if( j+jb<=n ) then
! compute rows j+jb:n of current block column
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, &
cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda )
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -&
cone, a( j, j ), lda,a( j+jb, j ), lda )
end if
! compute inverse of current diagonal block
call stdlib${ii}$_${ci}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$trtri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strti2( uplo, diag, n, a, lda, info )
!! STRTI2 computes the inverse of a real upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
real(sp) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_sscal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_strmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_strti2
pure module subroutine stdlib${ii}$_dtrti2( uplo, diag, n, a, lda, info )
!! DTRTI2 computes the inverse of a real upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
real(dp) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_dtrmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_dscal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_dtrmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_dtrti2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trti2( uplo, diag, n, a, lda, info )
!! DTRTI2: computes the inverse of a real upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
real(${rk}$) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = one / a( j, j )
ajj = -a( j, j )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_${ri}$trmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ri}$trti2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrti2( uplo, diag, n, a, lda, info )
!! CTRTI2 computes the inverse of a complex upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
complex(sp) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_ctrmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_cscal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_ctrmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_cscal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_ctrti2
pure module subroutine stdlib${ii}$_ztrti2( uplo, diag, n, a, lda, info )
!! ZTRTI2 computes the inverse of a complex upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
complex(dp) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_ztrmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zscal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_ztrmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_zscal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_ztrti2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trti2( uplo, diag, n, a, lda, info )
!! ZTRTI2: computes the inverse of a complex upper or lower triangular
!! matrix.
!! This is the 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
character, intent(in) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
complex(${ck}$) :: ajj
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRTI2', -info )
return
end if
if( upper ) then
! compute inverse of upper triangular matrix.
do j = 1, n
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( j-1, ajj, a( 1_${ik}$, j ), 1_${ik}$ )
end do
else
! compute inverse of lower triangular matrix.
do j = n, 1, -1
if( nounit ) then
a( j, j ) = cone / a( j, j )
ajj = -a( j, j )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_${ci}$trmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,a( j+1, j+1 ), lda, a( &
j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( n-j, ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$trti2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! STRRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by STRTRS or some other
!! means before entering this routine. STRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_scopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_strmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_saxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_strsv( uplo, transt, diag, n, a, lda, work( n+1 ),1_${ik}$ )
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}$_strsv( uplo, trans, diag, n, a, lda, work( n+1 ),1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_strrfs
pure module subroutine stdlib${ii}$_dtrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! DTRRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by DTRTRS or some other
!! means before entering this routine. DTRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_dcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dtrmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_daxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_dtrsv( uplo, transt, diag, n, a, lda, work( n+1 ),1_${ik}$ )
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}$_dtrsv( uplo, trans, diag, n, a, lda, work( n+1 ),1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_dtrrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! DTRRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by DTRTRS or some other
!! means before entering this routine. DTRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_${ri}$copy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$trmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$trsv( uplo, transt, diag, n, a, lda, work( n+1 ),1_${ik}$ )
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}$trsv( uplo, trans, diag, n, a, lda, work( n+1 ),1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ri}$trrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! CTRRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by CTRTRS or some other
!! means before entering this routine. CTRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ctrmv( uplo, trans, diag, n, a, lda, work, 1_${ik}$ )
call stdlib${ii}$_caxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_ctrsv( uplo, transt, diag, n, a, lda, work, 1_${ik}$ )
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}$_ctrsv( uplo, transn, diag, n, a, lda, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ctrrfs
pure module subroutine stdlib${ii}$_ztrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! ZTRRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by ZTRTRS or some other
!! means before entering this routine. ZTRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ztrmv( uplo, trans, diag, n, a, lda, work, 1_${ik}$ )
call stdlib${ii}$_zaxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_ztrsv( uplo, transt, diag, n, a, lda, work, 1_${ik}$ )
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}$_ztrsv( uplo, transn, diag, n, a, lda, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ztrrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,&
!! ZTRRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular
!! coefficient matrix.
!! The solution matrix X must be computed by ZTRTRS or some other
!! means before entering this routine. ZTRRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRRFS', -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_250: do j = 1, nrhs
! 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, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$trmv( uplo, trans, diag, n, a, lda, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$trsv( uplo, transt, diag, n, a, lda, work, 1_${ik}$ )
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}$trsv( uplo, transn, diag, n, a, lda, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ci}$trrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slauum( uplo, n, a, lda, info )
!! SLAUUM computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_slauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**t.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( &
i, i ), lda, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_slauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( &
1_${ik}$, i+ib ), lda,a( i, i+ib ), lda, one, a( 1_${ik}$, i ), lda )
call stdlib${ii}$_ssyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**t * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_strmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( &
i, i ), lda, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_slauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( &
i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, one, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_ssyrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), &
lda, one, a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_slauum
pure module subroutine stdlib${ii}$_dlauum( uplo, n, a, lda, info )
!! DLAUUM computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_dlauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**t.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( &
i, i ), lda, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_dlauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( &
1_${ik}$, i+ib ), lda,a( i, i+ib ), lda, one, a( 1_${ik}$, i ), lda )
call stdlib${ii}$_dsyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**t * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_dtrmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( &
i, i ), lda, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_dlauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( &
i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, one, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_dsyrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), &
lda, one, a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_dlauum
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lauum( uplo, n, a, lda, info )
!! DLAUUM: computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ri}$lauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**t.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( &
i, i ), lda, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_${ri}$lauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( &
1_${ik}$, i+ib ), lda,a( i, i+ib ), lda, one, a( 1_${ik}$, i ), lda )
call stdlib${ii}$_${ri}$syrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**t * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_${ri}$trmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( &
i, i ), lda, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ri}$lauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( &
i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, one, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ri}$syrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), &
lda, one, a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$lauum
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clauum( uplo, n, a, lda, info )
!! CLAUUM computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_clauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**h.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, &
ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda )
call stdlib${ii}$_clauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,&
cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_cherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**h * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,&
cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_clauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,&
cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_cherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+&
ib, i ), lda, one,a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_clauum
pure module subroutine stdlib${ii}$_zlauum( uplo, n, a, lda, info )
!! ZLAUUM computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_zlauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**h.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, &
ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda )
call stdlib${ii}$_zlauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,&
cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_zherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**h * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,&
cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_zlauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,&
cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_zherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+&
ib, i ), lda, one,a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_zlauum
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lauum( uplo, n, a, lda, info )
!! ZLAUUM: computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the blocked form of the algorithm, calling Level 3 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ib, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAUUM', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine the block size for this environment.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ci}$lauu2( uplo, n, a, lda, info )
else
! use blocked code
if( upper ) then
! compute the product u * u**h.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, &
ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda )
call stdlib${ii}$_${ci}$lauu2( 'UPPER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,&
cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda )
call stdlib${ii}$_${ci}$herk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),&
lda, one, a( i, i ),lda )
end if
end do
else
! compute the product l**h * l.
do i = 1, n, nb
ib = min( nb, n-i+1 )
call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,&
cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$lauu2( 'LOWER', ib, a( i, i ), lda, info )
if( i+ib<=n ) then
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,&
cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$herk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+&
ib, i ), lda, one,a( i, i ), lda )
end if
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$lauum
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slauu2( uplo, n, a, lda, info )
!! SLAUU2 computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**t.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_sdot( n-i+1, a( i, i ), lda, a( i, i ), lda )
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', i-1, n-i, one, a( 1_${ik}$, i+1 ),lda, a( i, i+1 )&
, lda, aii, a( 1_${ik}$, i ), 1_${ik}$ )
else
call stdlib${ii}$_sscal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**t * l.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_sdot( n-i+1, a( i, i ), 1_${ik}$, a( i, i ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-i, i-1, one, a( i+1, 1_${ik}$ ), lda,a( i+1, i ), &
1_${ik}$, aii, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_sscal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_slauu2
pure module subroutine stdlib${ii}$_dlauu2( uplo, n, a, lda, info )
!! DLAUU2 computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**t.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_ddot( n-i+1, a( i, i ), lda, a( i, i ), lda )
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', i-1, n-i, one, a( 1_${ik}$, i+1 ),lda, a( i, i+1 )&
, lda, aii, a( 1_${ik}$, i ), 1_${ik}$ )
else
call stdlib${ii}$_dscal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**t * l.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_ddot( n-i+1, a( i, i ), 1_${ik}$, a( i, i ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-i, i-1, one, a( i+1, 1_${ik}$ ), lda,a( i+1, i ), &
1_${ik}$, aii, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_dscal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_dlauu2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lauu2( uplo, n, a, lda, info )
!! DLAUU2: computes the product U * U**T or L**T * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(${rk}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**t.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_${ri}$dot( n-i+1, a( i, i ), lda, a( i, i ), lda )
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', i-1, n-i, one, a( 1_${ik}$, i+1 ),lda, a( i, i+1 )&
, lda, aii, a( 1_${ik}$, i ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$scal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**t * l.
do i = 1, n
aii = a( i, i )
if( i<n ) then
a( i, i ) = stdlib${ii}$_${ri}$dot( n-i+1, a( i, i ), 1_${ik}$, a( i, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-i, i-1, one, a( i+1, 1_${ik}$ ), lda,a( i+1, i ), &
1_${ik}$, aii, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_${ri}$scal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ri}$lauu2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clauu2( uplo, n, a, lda, info )
!! CLAUU2 computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(sp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**h.
do i = 1, n
aii = real( a( i, i ),KIND=sp)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_cdotc( n-i, a( i, i+1 ), lda,a( i, i+1 ), &
lda ),KIND=sp)
call stdlib${ii}$_clacgv( n-i, a( i, i+1 ), lda )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', i-1, n-i, cone, a( 1_${ik}$, i+1 ),lda, a( i, i+1 &
), lda, cmplx( aii,KIND=sp),a( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n-i, a( i, i+1 ), lda )
else
call stdlib${ii}$_csscal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**h * l.
do i = 1, n
aii = real( a( i, i ),KIND=sp)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_cdotc( n-i, a( i+1, i ), 1_${ik}$,a( i+1, i ), 1_${ik}$ )&
,KIND=sp)
call stdlib${ii}$_clacgv( i-1, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-i, i-1, cone,a( i+1, 1_${ik}$ ), lda, a( &
i+1, i ), 1_${ik}$,cmplx( aii,KIND=sp), a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_clacgv( i-1, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_csscal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_clauu2
pure module subroutine stdlib${ii}$_zlauu2( uplo, n, a, lda, info )
!! ZLAUU2 computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(dp) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**h.
do i = 1, n
aii = real( a( i, i ),KIND=dp)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_zdotc( n-i, a( i, i+1 ), lda,a( i, i+1 ), &
lda ),KIND=dp)
call stdlib${ii}$_zlacgv( n-i, a( i, i+1 ), lda )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', i-1, n-i, cone, a( 1_${ik}$, i+1 ),lda, a( i, i+1 &
), lda, cmplx( aii,KIND=dp),a( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n-i, a( i, i+1 ), lda )
else
call stdlib${ii}$_zdscal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**h * l.
do i = 1, n
aii = real( a( i, i ),KIND=dp)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_zdotc( n-i, a( i+1, i ), 1_${ik}$,a( i+1, i ), 1_${ik}$ )&
,KIND=dp)
call stdlib${ii}$_zlacgv( i-1, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-i, i-1, cone,a( i+1, 1_${ik}$ ), lda, a( &
i+1, i ), 1_${ik}$,cmplx( aii,KIND=dp), a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_zlacgv( i-1, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_zdscal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_zlauu2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lauu2( uplo, n, a, lda, info )
!! ZLAUU2: computes the product U * U**H or L**H * L, where the triangular
!! factor U or L is stored in the upper or lower triangular part of
!! the array A.
!! If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!! overwriting the factor U in A.
!! If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!! overwriting the factor L in A.
!! This is the unblocked form of the algorithm, calling Level 2 BLAS.
! -- 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(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(${ck}$) :: aii
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAUU2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the product u * u**h.
do i = 1, n
aii = real( a( i, i ),KIND=${ck}$)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_${ci}$dotc( n-i, a( i, i+1 ), lda,a( i, i+1 ), &
lda ),KIND=${ck}$)
call stdlib${ii}$_${ci}$lacgv( n-i, a( i, i+1 ), lda )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', i-1, n-i, cone, a( 1_${ik}$, i+1 ),lda, a( i, i+1 &
), lda, cmplx( aii,KIND=${ck}$),a( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n-i, a( i, i+1 ), lda )
else
call stdlib${ii}$_${ci}$dscal( i, aii, a( 1_${ik}$, i ), 1_${ik}$ )
end if
end do
else
! compute the product l**h * l.
do i = 1, n
aii = real( a( i, i ),KIND=${ck}$)
if( i<n ) then
a( i, i ) = aii*aii + real( stdlib${ii}$_${ci}$dotc( n-i, a( i+1, i ), 1_${ik}$,a( i+1, i ), 1_${ik}$ )&
,KIND=${ck}$)
call stdlib${ii}$_${ci}$lacgv( i-1, a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-i, i-1, cone,a( i+1, 1_${ik}$ ), lda, a( &
i+1, i ), 1_${ik}$,cmplx( aii,KIND=${ck}$), a( i, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$lacgv( i-1, a( i, 1_${ik}$ ), lda )
else
call stdlib${ii}$_${ci}$dscal( i, aii, a( i, 1_${ik}$ ), lda )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$lauu2
#:endif
#:endfor
module subroutine stdlib${ii}$_stpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info )
!! STPCON estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ap(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=sp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_slantp( norm, uplo, diag, n, ap, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_slatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_slatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( &
2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_stpcon
module subroutine stdlib${ii}$_dtpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info )
!! DTPCON estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ap(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=dp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_dlantp( norm, uplo, diag, n, ap, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_dlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_dlatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( &
2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_dtpcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$tpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info )
!! DTPCON: estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${rk}$) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=${rk}$)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_${ri}$lantp( norm, uplo, diag, n, ap, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_${ri}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_${ri}$latps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( &
2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ri}$tpcon
#:endif
#:endfor
module subroutine stdlib${ii}$_ctpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info )
!! CTPCON estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: ap(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=sp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_clantp( norm, uplo, diag, n, ap, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_clatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_clatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, &
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ctpcon
module subroutine stdlib${ii}$_ztpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info )
!! ZTPCON estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: ap(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=dp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_zlantp( norm, uplo, diag, n, ap, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_zlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_zlatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, &
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ztpcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$tpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info )
!! ZTPCON: estimates the reciprocal of the condition number of a packed
!! triangular matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${ck}$) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=${ck}$)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_${ci}$lantp( norm, uplo, diag, n, ap, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_${ci}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, &
rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_${ci}$latps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, &
scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ci}$tpcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! STPTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'STPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==zero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==zero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_stpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_stptrs
pure module subroutine stdlib${ii}$_dtptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! DTPTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'DTPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==zero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==zero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_dtpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_dtptrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! DTPTRS: solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'DTPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==zero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==zero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_${ri}$tpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_${ri}$tptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! CTPTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'CTPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==czero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==czero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_ctpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_ctptrs
pure module subroutine stdlib${ii}$_ztptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! ZTPTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'ZTPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==czero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==czero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_ztpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_ztptrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info )
!! ZTPTRS: solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular matrix of order N stored in packed format,
!! and B is an N-by-NRHS matrix. A check is made to verify that A is
!! nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) 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( 'ZTPTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
jc = 1_${ik}$
do info = 1, n
if( ap( jc+info-1 )==czero )return
jc = jc + info
end do
else
jc = 1_${ik}$
do info = 1, n
if( ap( jc )==czero )return
jc = jc + n - info + 1_${ik}$
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_${ci}$tpsv( uplo, trans, diag, n, ap, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_${ci}$tptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! SLATPS solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, x and b are n-element vectors, and s is a scaling
!! factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_sasum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_sasum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_stpsv can be used.
j = stdlib${ii}$_isamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ap( ip ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ap( ip ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_stpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_100: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 95
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
95 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_saxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_saxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_isamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_100
else
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_140: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_sdot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_sdot( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_sdot( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
sumj = sumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 135
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
135 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_140
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_slatps
pure module subroutine stdlib${ii}$_dlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! DLATPS solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, x and b are n-element vectors, and s is a scaling
!! factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(dp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_dasum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_dasum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_dtpsv can be used.
j = stdlib${ii}$_idamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ap( ip ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ap( ip ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_dtpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_daxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_daxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_idamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_110
else
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_ddot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_ddot( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_ddot( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
sumj = sumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dlatps
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! DLATPS: solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, x and b are n-element vectors, and s is a scaling
!! factor, usually less than or equal to 1, chosen so that the
!! components of x will be less than the overflow threshold. If the
!! unscaled problem will not cause overflow, the Level 2 BLAS routine
!! DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!! then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(out) :: scale
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(${rk}$) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_${ri}$asum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_${ri}$asum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_i${ri}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_${ri}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ri}$tpsv can be used.
j = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ap( ip ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ap( ip ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ri}$tpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_${ri}$scal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ri}$scal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_${ri}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_i${ri}$amax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_${ri}$axpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_i${ri}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_110
else
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ri}$dot to perform the dot product.
if( upper ) then
sumj = stdlib${ii}$_${ri}$dot( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
sumj = stdlib${ii}$_${ri}$dot( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
sumj = sumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
sumj = sumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${ri}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$latps
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! CLATPS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, A**H denotes the conjugate transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(inout) :: cnorm(*)
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(sp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(sp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=sp) / 2. ) +abs( aimag( zdum ) / 2. )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_scasum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_scasum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ctpsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ctpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 105
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
105 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_csscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_caxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_caxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_icamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_110
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_150: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_cdotu( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_cdotu( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 145
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
145 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_150
else
! solve a**h * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_190: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_cdotc( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_cdotc( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( ap( ip-j+i ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( conjg( ap( ip+i ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 185
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
185 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_190
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_clatps
pure module subroutine stdlib${ii}$_zlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! ZLATPS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, A**H denotes the conjugate transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(inout) :: cnorm(*)
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(dp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(dp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=dp) / 2._dp ) +abs( aimag( zdum ) / 2._dp )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_dzasum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_dzasum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ztpsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ztpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_zdscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_zaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_zaxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_izamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_zdotu( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_zdotu( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_170
else
! solve a**h * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_zdotc( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_zdotc( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( ap( ip-j+i ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( conjg( ap( ip+i ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zlatps
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info )
!! ZLATPS: solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular matrix stored in packed form. Here A**T denotes the
!! transpose of A, A**H denotes the conjugate transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(out) :: scale
! Array Arguments
real(${ck}$), intent(inout) :: cnorm(*)
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen
real(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(${ck}$) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATPS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
ip = 1_${ik}$
do j = 1, n
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( j-1, ap( ip ), 1_${ik}$ )
ip = ip + j
end do
else
! a is lower triangular.
ip = 1_${ik}$
do j = 1, n - 1
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( n-j, ap( ip+1 ), 1_${ik}$ )
ip = ip + n - j + 1_${ik}$
end do
cnorm( n ) = zero
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_${c2ri(ci)}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ci}$tpsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = n
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
ip = ip + jinc*jlen
jlen = jlen - 1_${ik}$
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ap( ip )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ci}$tpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ci}$dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j)
call stdlib${ii}$_${ci}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ )
i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip - j
else
if( j<n ) then
! compute the update
! x(j+1:n) := x(j+1:n) - x(j) * a(j+1:n,j)
call stdlib${ii}$_${ci}$axpy( n-j, -x( j )*tscal, ap( ip+1 ), 1_${ik}$,x( j+1 ), 1_${ik}$ )
i = j + stdlib${ii}$_i${ci}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
ip = ip + n - j + 1_${ik}$
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ap( ip )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotu to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_${ci}$dotu( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_${ci}$dotu( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ap( ip )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_170
else
! solve a**h * x = b
ip = jfirst*( jfirst+1 ) / 2_${ik}$
jlen = 1_${ik}$
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotc to perform the dot product.
if( upper ) then
csumj = stdlib${ii}$_${ci}$dotc( j-1, ap( ip-j+1 ), 1_${ik}$, x, 1_${ik}$ )
else if( j<n ) then
csumj = stdlib${ii}$_${ci}$dotc( n-j, ap( ip+1 ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
do i = 1, j - 1
csumj = csumj + ( conjg( ap( ip-j+i ) )*uscal )*x( i )
end do
else if( j<n ) then
do i = 1, n - j
csumj = csumj + ( conjg( ap( ip+i ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ap( ip ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
jlen = jlen + 1_${ik}$
ip = ip + jinc*jlen
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$latps
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stptri( uplo, diag, n, ap, info )
!! STPTRI computes the inverse of a real upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
real(sp) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==zero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==zero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = one / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_stpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_sscal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = one / ap( jc )
ajj = -ap( jc )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_stpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_stptri
pure module subroutine stdlib${ii}$_dtptri( uplo, diag, n, ap, info )
!! DTPTRI computes the inverse of a real upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
real(dp) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==zero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==zero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = one / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_dtpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_dscal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = one / ap( jc )
ajj = -ap( jc )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_dtpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_dtptri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tptri( uplo, diag, n, ap, info )
!! DTPTRI: computes the inverse of a real upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
real(${rk}$) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==zero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==zero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = one / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -one
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_${ri}$tpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = one / ap( jc )
ajj = -ap( jc )
else
ajj = -one
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_${ri}$tpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_${ri}$tptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctptri( uplo, diag, n, ap, info )
!! CTPTRI computes the inverse of a complex upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
complex(sp) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==czero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==czero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = cone / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_ctpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_cscal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = cone / ap( jc )
ajj = -ap( jc )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_ctpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_cscal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_ctptri
pure module subroutine stdlib${ii}$_ztptri( uplo, diag, n, ap, info )
!! ZTPTRI computes the inverse of a complex upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
complex(dp) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==czero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==czero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = cone / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_ztpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_zscal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = cone / ap( jc )
ajj = -ap( jc )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_ztpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_zscal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_ztptri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tptri( uplo, diag, n, ap, info )
!! ZTPTRI: computes the inverse of a complex upper or lower triangular
!! matrix A stored in packed format.
! -- 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) :: diag, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j, jc, jclast, jj
complex(${ck}$) :: ajj
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPTRI', -info )
return
end if
! check for singularity if non-unit.
if( nounit ) then
if( upper ) then
jj = 0_${ik}$
do info = 1, n
jj = jj + info
if( ap( jj )==czero )return
end do
else
jj = 1_${ik}$
do info = 1, n
if( ap( jj )==czero )return
jj = jj + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
end if
if( upper ) then
! compute inverse of upper triangular matrix.
jc = 1_${ik}$
do j = 1, n
if( nounit ) then
ap( jc+j-1 ) = cone / ap( jc+j-1 )
ajj = -ap( jc+j-1 )
else
ajj = -cone
end if
! compute elements 1:j-1 of j-th column.
call stdlib${ii}$_${ci}$tpmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, ap,ap( jc ), 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( j-1, ajj, ap( jc ), 1_${ik}$ )
jc = jc + j
end do
else
! compute inverse of lower triangular matrix.
jc = n*( n+1 ) / 2_${ik}$
do j = n, 1, -1
if( nounit ) then
ap( jc ) = cone / ap( jc )
ajj = -ap( jc )
else
ajj = -cone
end if
if( j<n ) then
! compute elements j+1:n of j-th column.
call stdlib${ii}$_${ci}$tpmv( 'LOWER', 'NO TRANSPOSE', diag, n-j,ap( jclast ), ap( jc+1 )&
, 1_${ik}$ )
call stdlib${ii}$_${ci}$scal( n-j, ajj, ap( jc+1 ), 1_${ik}$ )
end if
jclast = jc
jc = jc - n + j - 2_${ik}$
end do
end if
return
end subroutine stdlib${ii}$_${ci}$tptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! STPRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by STPTRS or some other
!! means before entering this routine. STPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STPRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_scopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_stpmv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_saxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$_stpsv( uplo, transt, diag, n, ap, work( n+1 ), 1_${ik}$ )
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}$_stpsv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_stprfs
pure module subroutine stdlib${ii}$_dtprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! DTPRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by DTPTRS or some other
!! means before entering this routine. DTPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_dcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dtpmv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_daxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$_dtpsv( uplo, transt, diag, n, ap, work( n+1 ), 1_${ik}$ )
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}$_dtpsv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_dtprfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! DTPRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by DTPTRS or some other
!! means before entering this routine. DTPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTPRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_${ri}$copy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$tpmv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( kc+i-1 ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, n
work( i ) = work( i ) + abs( ap( kc+i-k ) )*xk
end do
work( k ) = work( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = 1, k - 1
s = s + abs( ap( kc+i-1 ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, n
s = s + abs( ap( kc+i-k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$tpsv( uplo, transt, diag, n, ap, work( n+1 ), 1_${ik}$ )
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}$tpsv( uplo, trans, diag, n, ap, work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ri}$tprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! CTPRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by CTPTRS or some other
!! means before entering this routine. CTPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTPRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ctpmv( uplo, trans, diag, n, ap, work, 1_${ik}$ )
call stdlib${ii}$_caxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$_ctpsv( uplo, transt, diag, n, ap, work, 1_${ik}$ )
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}$_ctpsv( uplo, transn, diag, n, ap, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ctprfs
pure module subroutine stdlib${ii}$_ztprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! ZTPRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by ZTPTRS or some other
!! means before entering this routine. ZTPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPRFS', -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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ztpmv( uplo, trans, diag, n, ap, work, 1_${ik}$ )
call stdlib${ii}$_zaxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$_ztpsv( uplo, transt, diag, n, ap, work, 1_${ik}$ )
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}$_ztpsv( uplo, transn, diag, n, ap, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ztprfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, &
!! ZTPRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular packed
!! coefficient matrix.
!! The solution matrix X must be computed by ZTPTRS or some other
!! means before entering this routine. ZTPRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: ap(*), b(ldb,*), x(ldx,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: i, j, k, kase, kc, 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTPRFS', -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_250: do j = 1, nrhs
! 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, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$tpmv( uplo, trans, diag, n, ap, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
kc = kc + k
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-1 ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, n
rwork( i ) = rwork( i ) +cabs1( ap( kc+i-k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
kc = kc + n - k + 1_${ik}$
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = 1, k
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = 1, k - 1
s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + k
end do
end if
else
kc = 1_${ik}$
if( nounit ) then
do k = 1, n
s = zero
do i = k, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, n
s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
kc = kc + n - k + 1_${ik}$
end do
end if
end if
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
! 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}$
210 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}$tpsv( uplo, transt, diag, n, ap, work, 1_${ik}$ )
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}$tpsv( uplo, transn, diag, n, ap, work, 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ci}$tprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stftri( transr, uplo, diag, n, a, info )
!! STFTRI computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_strtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_strtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'U', 'T', diag, n2, n1, one, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_strtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_strtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'U', 'N', diag, n1, n2, one, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_strtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_strtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'L', 'T', diag, n1, n2, one, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_strtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'U', 'T', diag, n2, n1, -one,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_strtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'L', 'N', diag, n2, n1, one,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_strtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'L', 'N', diag, k, k, -one, a( 1_${ik}$ ),n+1, a( k+1 ), n+1 &
)
call stdlib${ii}$_strtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'U', 'T', diag, k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_strtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 &
)
call stdlib${ii}$_strtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'U', 'N', diag, k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_strtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_strtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'L', 'T', diag, k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_strtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_strmm( 'R', 'U', 'T', diag, k, k, -one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_strtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_strmm( 'L', 'L', 'N', diag, k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_stftri
pure module subroutine stdlib${ii}$_dtftri( transr, uplo, diag, n, a, info )
!! DTFTRI computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_dtrtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_dtrtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'U', 'T', diag, n2, n1, one, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_dtrtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_dtrtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'U', 'N', diag, n1, n2, one, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_dtrtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_dtrtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'L', 'T', diag, n1, n2, one, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_dtrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', diag, n2, n1, -one,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_dtrtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'L', 'N', diag, n2, n1, one,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_dtrtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'L', 'N', diag, k, k, -one, a( 1_${ik}$ ),n+1, a( k+1 ), n+1 &
)
call stdlib${ii}$_dtrtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'U', 'T', diag, k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_dtrtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 &
)
call stdlib${ii}$_dtrtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'U', 'N', diag, k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_dtrtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_dtrtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'L', 'T', diag, k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_dtrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', diag, k, k, -one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_dtrtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_dtrmm( 'L', 'L', 'N', diag, k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_dtftri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tftri( transr, uplo, diag, n, a, info )
!! DTFTRI: computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_${ri}$trtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_${ri}$trtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'T', diag, n2, n1, one, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_${ri}$trtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_${ri}$trtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', diag, n1, n2, one, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_${ri}$trtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_${ri}$trtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'T', diag, n1, n2, one, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_${ri}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', diag, n2, n1, -one,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_${ri}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', diag, n2, n1, one,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_${ri}$trtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', diag, k, k, -one, a( 1_${ik}$ ),n+1, a( k+1 ), n+1 &
)
call stdlib${ii}$_${ri}$trtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'T', diag, k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_${ri}$trtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 &
)
call stdlib${ii}$_${ri}$trtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', diag, k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_${ri}$trtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_${ri}$trtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'T', diag, k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_${ri}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', diag, k, k, -one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_${ri}$trtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', diag, k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$tftri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctftri( transr, uplo, diag, n, a, info )
!! CTFTRI computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_ctrtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_ctrtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_ctrtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_ctrtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_ctrtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_ctrtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_ctrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_ctrtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_ctrtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+&
1_${ik}$ )
call stdlib${ii}$_ctrtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 &
)
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_ctrtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+&
1_${ik}$ )
call stdlib${ii}$_ctrtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_ctrtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),&
k )
call stdlib${ii}$_ctrtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_ctrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),&
k )
call stdlib${ii}$_ctrtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ctrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_ctftri
pure module subroutine stdlib${ii}$_ztftri( transr, uplo, diag, n, a, info )
!! ZTFTRI computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_ztrtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_ztrtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_ztrtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_ztrtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_ztrtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_ztrtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_ztrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_ztrtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_ztrtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+&
1_${ik}$ )
call stdlib${ii}$_ztrtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 &
)
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_ztrtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+&
1_${ik}$ )
call stdlib${ii}$_ztrtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_ztrtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),&
k )
call stdlib${ii}$_ztrtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_ztrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),&
k )
call stdlib${ii}$_ztrtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_ztrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_ztftri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tftri( transr, uplo, diag, n, a, info )
!! ZTFTRI: computes the inverse of a triangular matrix A stored in RFP
!! format.
!! This is a 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
character, intent(in) :: transr, uplo, diag
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(inout) :: a(0_${ik}$:*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, nisodd, normaltransr
integer(${ik}$) :: n1, n2, k
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
normaltransr = stdlib_lsame( transr, 'N' )
lower = stdlib_lsame( uplo, 'L' )
if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) then
info = -1_${ik}$
else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( diag, 'N' ) .and. .not.stdlib_lsame( diag, 'U' ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! if n is odd, set nisodd = .true.
! if n is even, set k = n/2 and nisodd = .false.
if( mod( n, 2_${ik}$ )==0_${ik}$ ) then
k = n / 2_${ik}$
nisodd = .false.
else
nisodd = .true.
end if
! set n1 and n2 depending on lower
if( lower ) then
n2 = n / 2_${ik}$
n1 = n - n2
else
n1 = n / 2_${ik}$
n2 = n - n1
end if
! start execution: there are eight cases
if( nisodd ) then
! n is odd
if( normaltransr ) then
! n is odd and transr = 'n'
if( lower ) then
! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) )
! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0)
! t1 -> a(0), t2 -> a(n), s -> a(n1)
call stdlib${ii}$_${ci}$trtri( 'L', diag, n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n )
call stdlib${ii}$_${ci}$trtri( 'U', diag, n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n )
else
! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1)
! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0)
! t1 -> a(n2), t2 -> a(n1), s -> a(0)
call stdlib${ii}$_${ci}$trtri( 'L', diag, n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n )
call stdlib${ii}$_${ci}$trtri( 'U', diag, n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n )
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1)
call stdlib${ii}$_${ci}$trtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), &
n1 )
call stdlib${ii}$_${ci}$trtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), &
n1 )
else
! srpa for upper, transpose and n is odd
! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0)
call stdlib${ii}$_${ci}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_${ci}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), &
n2 )
end if
end if
else
! n is even
if( normaltransr ) then
! n is even and transr = 'n'
if( lower ) then
! srpa for lower, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0)
! t1 -> a(1), t2 -> a(0), s -> a(k+1)
call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+&
1_${ik}$ )
call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 &
)
else
! srpa for upper, normal, and n is even ( a(0:n,0:k-1) )
! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0)
! t1 -> a(k+1), t2 -> a(k), s -> a(0)
call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+&
1_${ik}$ )
call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
end if
else
! n is even and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is even (see paper)
! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1)
! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k
call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k ), k, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),&
k )
call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
else
! srpa for upper, transpose and n is even (see paper)
! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0)
! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k
call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),&
k )
call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
if( info>0 )return
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$tftri
#:endif
#:endfor
module subroutine stdlib${ii}$_stbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info )
!! STBCON estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=sp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_slantb( norm, uplo, diag, n, kd, ab, ldab, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_slatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_slatbs( uplo, 'TRANSPOSE', diag, normin, n, kd, ab,ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_stbcon
module subroutine stdlib${ii}$_dtbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info )
!! DTBCON estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=dp)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_dlantb( norm, uplo, diag, n, kd, ab, ldab, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_dlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_dlatbs( uplo, 'TRANSPOSE', diag, normin, n, kd, ab,ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_dtbcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$tbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info )
!! DTBCON: estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${rk}$) :: ainvnm, anorm, scale, smlnum, xnorm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )*real( max( 1_${ik}$, n ),KIND=${rk}$)
! compute the norm of the triangular matrix a.
anorm = stdlib${ii}$_${ri}$lantb( norm, uplo, diag, n, kd, ab, ldab, work )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the norm of the inverse of 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(a).
call stdlib${ii}$_${ri}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(a**t).
call stdlib${ii}$_${ri}$latbs( uplo, 'TRANSPOSE', diag, normin, n, kd, ab,ldab, work, &
scale, work( 2_${ik}$*n+1 ), info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
xnorm = abs( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ri}$tbcon
#:endif
#:endfor
module subroutine stdlib${ii}$_ctbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info )
!! CTBCON estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: ab(ldab,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(sp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )*real( max( n, 1_${ik}$ ),KIND=sp)
! compute the 1-norm of the triangular matrix a or a**h.
anorm = stdlib${ii}$_clantb( norm, uplo, diag, n, kd, ab, ldab, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the 1-norm of the inverse of 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(a).
call stdlib${ii}$_clatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_clatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,&
work, scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ctbcon
module subroutine stdlib${ii}$_ztbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info )
!! ZTBCON estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: ab(ldab,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(dp) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )*real( max( n, 1_${ik}$ ),KIND=dp)
! compute the 1-norm of the triangular matrix a or a**h.
anorm = stdlib${ii}$_zlantb( norm, uplo, diag, n, kd, ab, ldab, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the 1-norm of the inverse of 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(a).
call stdlib${ii}$_zlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_zlatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,&
work, scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_ztbcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$tbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info )
!! ZTBCON: estimates the reciprocal of the condition number of a
!! triangular band matrix A, in either the 1-norm or the infinity-norm.
!! The norm of A is computed and an estimate is obtained for
!! norm(inv(A)), then 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) :: diag, norm, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, onenrm, upper
character :: normin
integer(${ik}$) :: ix, kase, kase1
real(${ck}$) :: ainvnm, anorm, scale, smlnum, xnorm
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}$
upper = stdlib_lsame( uplo, 'U' )
onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<kd+1 ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTBCON', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
rcond = one
return
end if
rcond = zero
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )*real( max( n, 1_${ik}$ ),KIND=${ck}$)
! compute the 1-norm of the triangular matrix a or a**h.
anorm = stdlib${ii}$_${ci}$lantb( norm, uplo, diag, n, kd, ab, ldab, rwork )
! continue only if anorm > 0.
if( anorm>zero ) then
! estimate the 1-norm of the inverse of 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(a).
call stdlib${ii}$_${ci}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, &
scale, rwork, info )
else
! multiply by inv(a**h).
call stdlib${ii}$_${ci}$latbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,&
work, scale, rwork, info )
end if
normin = 'Y'
! multiply by 1/scale if doing so will not cause overflow.
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
xnorm = cabs1( work( ix ) )
if( scale<xnorm*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 / anorm ) / ainvnm
end if
20 continue
return
end subroutine stdlib${ii}$_${ci}$tbcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! STBTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==zero )return
end do
else
do info = 1, n
if( ab( 1, info )==zero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_stbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_stbtrs
pure module subroutine stdlib${ii}$_dtbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! DTBTRS solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==zero )return
end do
else
do info = 1, n
if( ab( 1, info )==zero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_dtbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_dtbtrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! DTBTRS: solves a triangular system of the form
!! A * X = B or A**T * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==zero )return
end do
else
do info = 1, n
if( ab( 1, info )==zero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b or a**t * x = b.
do j = 1, nrhs
call stdlib${ii}$_${ri}$tbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_${ri}$tbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! CTBTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by-NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
complex(sp), intent(in) :: ab(ldab,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==czero )return
end do
else
do info = 1, n
if( ab( 1, info )==czero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_ctbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_ctbtrs
pure module subroutine stdlib${ii}$_ztbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! ZTBTRS solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by-NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
complex(dp), intent(in) :: ab(ldab,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==czero )return
end do
else
do info = 1, n
if( ab( 1, info )==czero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_ztbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_ztbtrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info )
!! ZTBTRS: solves a triangular system of the form
!! A * X = B, A**T * X = B, or A**H * X = B,
!! where A is a triangular band matrix of order N, and B is an
!! N-by-NRHS matrix. A check is made to verify that A is nonsingular.
! -- 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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs
! Array Arguments
complex(${ck}$), intent(in) :: ab(ldab,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: nounit, upper
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nounit = stdlib_lsame( diag, 'N' )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. &
.not.stdlib_lsame( trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTBTRS', -info )
return
end if
! quick return if possible
if( n==0 )return
! check for singularity.
if( nounit ) then
if( upper ) then
do info = 1, n
if( ab( kd+1, info )==czero )return
end do
else
do info = 1, n
if( ab( 1, info )==czero )return
end do
end if
end if
info = 0_${ik}$
! solve a * x = b, a**t * x = b, or a**h * x = b.
do j = 1, nrhs
call stdlib${ii}$_${ci}$tbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1_${ik}$, j ), 1_${ik}$ )
end do
return
end subroutine stdlib${ii}$_${ci}$tbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! SLATBS solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine STBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_sasum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_sasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_stbsv can be used.
j = stdlib${ii}$_isamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_stbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_100: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 95
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
95 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_saxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_saxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_isamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end do loop_100
else
! solve a**t * x = b
loop_140: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_sdot to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
sumj = stdlib${ii}$_sdot( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )sumj = stdlib${ii}$_sdot( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
sumj = sumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 135
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
135 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_140
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_slatbs
pure module subroutine stdlib${ii}$_dlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! DLATBS solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(dp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_dasum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_dasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_dtbsv can be used.
j = stdlib${ii}$_idamax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_dtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_daxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_daxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_idamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end do loop_110
else
! solve a**t * x = b
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_ddot to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
sumj = stdlib${ii}$_ddot( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )sumj = stdlib${ii}$_ddot( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
sumj = sumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dlatbs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! DLATBS: solves one of the triangular systems
!! A *x = s*b or A**T*x = s*b
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${rk}$), intent(out) :: scale
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(inout) :: cnorm(*), x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(${rk}$) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, &
xmax
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_${ri}$asum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_${ri}$asum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum.
imax = stdlib${ii}$_i${ri}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum ) then
tscal = one
else
tscal = one / ( smlnum*tmax )
call stdlib${ii}$_${ri}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ri}$tbsv can be used.
j = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ )
xmax = abs( x( j ) )
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 50
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! m(j) = g(j-1) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
xbnd = min( xbnd, min( one, tjj )*grow )
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 50
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
50 continue
else
! compute the growth in a**t * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 80
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = one / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
tjj = abs( ab( maind, j ) )
if( xj>tjj )xbnd = xbnd*( tjj / xj )
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, one / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 80
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
80 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ri}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = bignum / xmax
call stdlib${ii}$_${ri}$scal( n, scale, x, 1_${ik}$ )
xmax = bignum
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = abs( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 100
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
xj = abs( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
100 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ri}$scal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_${ri}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_i${ri}$amax( j-1, x, 1_${ik}$ )
xmax = abs( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_${ri}$axpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_i${ri}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = abs( x( i ) )
end if
end do loop_110
else
! solve a**t * x = b
loop_160: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = abs( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = abs( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = uscal / tjjs
end if
if( rec<one ) then
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
sumj = zero
if( uscal==one ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ri}$dot to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
sumj = stdlib${ii}$_${ri}$dot( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )sumj = stdlib${ii}$_${ri}$dot( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
sumj = sumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==tscal ) then
! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - sumj
xj = abs( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 150
end if
tjj = abs( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = x( j ) / tjjs
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = x( j ) / tjjs
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a**t*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
150 continue
else
! compute x(j) := x(j) / a(j,j) - sumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = x( j ) / tjjs - sumj
end if
xmax = max( xmax, abs( x( j ) ) )
end do loop_160
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${ri}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$latbs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! CLATBS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(inout) :: cnorm(*)
complex(sp), intent(in) :: ab(ldab,*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(sp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(sp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=sp) / 2. ) +abs( aimag( zdum ) / 2. )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_slamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_scasum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_scasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ctbsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ctbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_110: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 105
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
105 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_csscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_caxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_caxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_icamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end do loop_110
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_150: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotu to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_cdotu( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_cdotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 145
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
145 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_150
else
! solve a**h * x = b
loop_190: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_cladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=sp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_cdotc to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_cdotc( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_cdotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( conjg( ab( kd+i-jlen, j ) )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( conjg( ab( i+1, j ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=sp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 185
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
185 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_190
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_clatbs
pure module subroutine stdlib${ii}$_zlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! ZLATBS solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(inout) :: cnorm(*)
complex(dp), intent(in) :: ab(ldab,*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(dp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(dp) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=dp) / 2._dp ) +abs( aimag( zdum ) / 2._dp )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_dlamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_dzasum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_dzasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_ztbsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_ztbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_zdscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_zaxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_zaxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_izamax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotu to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_zdotu( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_zdotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_170
else
! solve a**h * x = b
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_zladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=dp) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_zdotc to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_zdotc( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_zdotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( conjg( ab( kd+i-jlen, j ) )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( conjg( ab( i+1, j ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=dp) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zlatbs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, &
!! ZLATBS: solves one of the triangular systems
!! A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
!! with scaling to prevent overflow, where A is an upper or lower
!! triangular band matrix. Here A**T denotes the transpose of A, x and b
!! are n-element vectors, and s is a scaling factor, usually less than
!! or equal to 1, chosen so that the components of x will be less than
!! the overflow threshold. If the unscaled problem will not cause
!! overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A
!! is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!! non-trivial solution to A*x = 0 is returned.
info )
! -- 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(in) :: diag, normin, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${ck}$), intent(out) :: scale
! Array Arguments
real(${ck}$), intent(inout) :: cnorm(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind
real(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax
complex(${ck}$) :: csumj, tjjs, uscal, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1, cabs2
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ )
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
! test the input parameters.
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) &
then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( kd<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLATBS', -info )
return
end if
! quick return if possible
if( n==0 )return
! determine machine dependent parameters to control overflow.
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = smlnum / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
bignum = one / smlnum
scale = one
if( stdlib_lsame( normin, 'N' ) ) then
! compute the 1-norm of each column, not including the diagonal.
if( upper ) then
! a is upper triangular.
do j = 1, n
jlen = min( kd, j-1 )
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( jlen, ab( kd+1-jlen, j ), 1_${ik}$ )
end do
else
! a is lower triangular.
do j = 1, n
jlen = min( kd, n-j )
if( jlen>0_${ik}$ ) then
cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ )
else
cnorm( j ) = zero
end if
end do
end if
end if
! scale the column norms by tscal if the maximum element in cnorm is
! greater than bignum/2.
imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, cnorm, 1_${ik}$ )
tmax = cnorm( imax )
if( tmax<=bignum*half ) then
tscal = one
else
tscal = half / ( smlnum*tmax )
call stdlib${ii}$_${c2ri(ci)}$scal( n, tscal, cnorm, 1_${ik}$ )
end if
! compute a bound on the computed solution vector to see if the
! level 2 blas routine stdlib${ii}$_${ci}$tbsv can be used.
xmax = zero
do j = 1, n
xmax = max( xmax, cabs2( x( j ) ) )
end do
xbnd = xmax
if( notran ) then
! compute the growth in a * x = b.
if( upper ) then
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 60
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, g(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = g(j-1) / abs(a(j,j))
xbnd = min( xbnd, min( one, tjj )*grow )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
if( tjj+cnorm( j )>=smlnum ) then
! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) )
grow = grow*( tjj / ( tjj+cnorm( j ) ) )
else
! g(j) could overflow, set grow to 0.
grow = zero
end if
end do
grow = xbnd
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 60
! g(j) = g(j-1)*( 1 + cnorm(j) )
grow = grow*( one / ( one+cnorm( j ) ) )
end do
end if
60 continue
else
! compute the growth in a**t * x = b or a**h * x = b.
if( upper ) then
jfirst = 1_${ik}$
jlast = n
jinc = 1_${ik}$
maind = kd + 1_${ik}$
else
jfirst = n
jlast = 1_${ik}$
jinc = -1_${ik}$
maind = 1_${ik}$
end if
if( tscal/=one ) then
grow = zero
go to 90
end if
if( nounit ) then
! a is non-unit triangular.
! compute grow = 1/g(j) and xbnd = 1/m(j).
! initially, m(0) = max{x(i), i=1,...,n}.
grow = half / max( xbnd, smlnum )
xbnd = grow
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) )
xj = one + cnorm( j )
grow = min( grow, xbnd / xj )
tjjs = ab( maind, j )
tjj = cabs1( tjjs )
if( tjj>=smlnum ) then
! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j))
if( xj>tjj )xbnd = xbnd*( tjj / xj )
else
! m(j) could overflow, set xbnd to 0.
xbnd = zero
end if
end do
grow = min( grow, xbnd )
else
! a is unit triangular.
! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}.
grow = min( one, half / max( xbnd, smlnum ) )
do j = jfirst, jlast, jinc
! exit the loop if the growth factor is too small.
if( grow<=smlnum )go to 90
! g(j) = ( 1 + cnorm(j) )*g(j-1)
xj = one + cnorm( j )
grow = grow / xj
end do
end if
90 continue
end if
if( ( grow*tscal )>smlnum ) then
! use the level 2 blas solve if the reciprocal of the bound on
! elements of x is not too small.
call stdlib${ii}$_${ci}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ )
else
! use a level 1 blas solve, scaling intermediate results.
if( xmax>bignum*half ) then
! scale x so that its components are less than or equal to
! bignum in absolute value.
scale = ( bignum*half ) / xmax
call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ )
xmax = bignum
else
xmax = xmax*two
end if
if( notran ) then
! solve a * x = b
loop_120: do j = jfirst, jlast, jinc
! compute x(j) = b(j) / a(j,j), scaling x if necessary.
xj = cabs1( x( j ) )
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 110
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/b(j).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum
! to avoid overflow when dividing by a(j,j).
rec = ( tjj*bignum ) / xj
if( cnorm( j )>one ) then
! scale by 1/cnorm(j) to avoid overflow when
! multiplying x(j) times column j.
rec = rec / cnorm( j )
end if
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
xj = cabs1( x( j ) )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0, and compute a solution to a*x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
xj = one
scale = zero
xmax = zero
end if
110 continue
! scale x if necessary to avoid overflow when adding a
! multiple of column j of a.
if( xj>one ) then
rec = one / xj
if( cnorm( j )>( bignum-xmax )*rec ) then
! scale x by 1/(2*abs(x(j))).
rec = rec*half
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
end if
else if( xj*cnorm( j )>( bignum-xmax ) ) then
! scale x by 1/2.
call stdlib${ii}$_${ci}$dscal( n, half, x, 1_${ik}$ )
scale = scale*half
end if
if( upper ) then
if( j>1_${ik}$ ) then
! compute the update
! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
! x(j)* a(max(1,j-kd):j-1,j)
jlen = min( kd, j-1 )
call stdlib${ii}$_${ci}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen &
), 1_${ik}$ )
i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
else if( j<n ) then
! compute the update
! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
! x(j) * a(j+1:min(j+kd,n),j)
jlen = min( kd, n-j )
if( jlen>0_${ik}$ )call stdlib${ii}$_${ci}$axpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),&
1_${ik}$ )
i = j + stdlib${ii}$_i${ci}$amax( n-j, x( j+1 ), 1_${ik}$ )
xmax = cabs1( x( i ) )
end if
end do loop_120
else if( stdlib_lsame( trans, 'T' ) ) then
! solve a**t * x = b
loop_170: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotu to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_${ci}$dotu( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_${ci}$dotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = ab( maind, j )*tscal
else
tjjs = tscal
if( tscal==one )go to 160
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**t *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
160 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_170
else
! solve a**h * x = b
loop_220: do j = jfirst, jlast, jinc
! compute x(j) = b(j) - sum a(k,j)*x(k).
! k<>j
xj = cabs1( x( j ) )
uscal = tscal
rec = one / max( xmax, one )
if( cnorm( j )>( bignum-xj )*rec ) then
! if x(j) could overflow, scale x by 1/(2*xmax).
rec = rec*half
if( nounit ) then
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
end if
tjj = cabs1( tjjs )
if( tjj>one ) then
! divide by a(j,j) when scaling x if a(j,j) > 1.
rec = min( one, rec*tjj )
uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs )
end if
if( rec<one ) then
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
csumj = zero
if( uscal==cmplx( one,KIND=${ck}$) ) then
! if the scaling needed for a in the dot product is 1,
! call stdlib${ii}$_${ci}$dotc to perform the dot product.
if( upper ) then
jlen = min( kd, j-1 )
csumj = stdlib${ii}$_${ci}$dotc( jlen, ab( kd+1-jlen, j ), 1_${ik}$,x( j-jlen ), 1_${ik}$ )
else
jlen = min( kd, n-j )
if( jlen>1_${ik}$ )csumj = stdlib${ii}$_${ci}$dotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ )
end if
else
! otherwise, use in-line code for the dot product.
if( upper ) then
jlen = min( kd, j-1 )
do i = 1, jlen
csumj = csumj + ( conjg( ab( kd+i-jlen, j ) )*uscal )*x( j-jlen-1+i )
end do
else
jlen = min( kd, n-j )
do i = 1, jlen
csumj = csumj + ( conjg( ab( i+1, j ) )*uscal )*x( j+i )
end do
end if
end if
if( uscal==cmplx( tscal,KIND=${ck}$) ) then
! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j)
! was not used to scale the dotproduct.
x( j ) = x( j ) - csumj
xj = cabs1( x( j ) )
if( nounit ) then
! compute x(j) = x(j) / a(j,j), scaling if necessary.
tjjs = conjg( ab( maind, j ) )*tscal
else
tjjs = tscal
if( tscal==one )go to 210
end if
tjj = cabs1( tjjs )
if( tjj>smlnum ) then
! abs(a(j,j)) > smlnum:
if( tjj<one ) then
if( xj>tjj*bignum ) then
! scale x by 1/abs(x(j)).
rec = one / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else if( tjj>zero ) then
! 0 < abs(a(j,j)) <= smlnum:
if( xj>tjj*bignum ) then
! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum.
rec = ( tjj*bignum ) / xj
call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ )
scale = scale*rec
xmax = xmax*rec
end if
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs )
else
! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and
! scale = 0 and compute a solution to a**h *x = 0.
do i = 1, n
x( i ) = zero
end do
x( j ) = one
scale = zero
xmax = zero
end if
210 continue
else
! compute x(j) := x(j) / a(j,j) - csumj if the dot
! product has already been divided by 1/a(j,j).
x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj
end if
xmax = max( xmax, cabs1( x( j ) ) )
end do loop_220
end if
scale = scale / tscal
end if
! scale the column norms by 1/tscal for return.
if( tscal/=one ) then
call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$latbs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! STBRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by STBTRS or some other
!! means before entering this routine. STBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'STBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_scopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_stbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),1_${ik}$ )
call stdlib${ii}$_saxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_stbsv( uplo, transt, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
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}$_stbsv( uplo, trans, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_stbrfs
pure module subroutine stdlib${ii}$_dtbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! DTBRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by DTBTRS or some other
!! means before entering this routine. DTBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'DTBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_dcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dtbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),1_${ik}$ )
call stdlib${ii}$_daxpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_dtbsv( uplo, transt, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
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}$_dtbsv( uplo, trans, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_dtbrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! DTBRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by DTBTRS or some other
!! means before entering this routine. DTBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'DTBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a or a**t, depending on trans.
call stdlib${ii}$_${ri}$copy( n, x( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$tbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n, -one, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) +abs( ab( kd+1+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = abs( x( k, j ) )
do i = k, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( 1_${ik}$+i-k, k ) )*xk
end do
work( k ) = work( k ) + xk
end do
end if
end if
else
! compute abs(a**t)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + abs( ab( kd+1+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
else
do k = 1, n
s = abs( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + abs( ab( 1_${ik}$+i-k, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
end if
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
! 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}$
210 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}$tbsv( uplo, transt, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
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}$tbsv( uplo, trans, diag, n, kd, ab, ldab,work( n+1 ), 1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ri}$tbrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! CTBRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by CTBTRS or some other
!! means before entering this routine. CTBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'CTBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_ccopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ctbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1_${ik}$ )
call stdlib${ii}$_caxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_ctbsv( uplo, transt, diag, n, kd, ab, ldab, work,1_${ik}$ )
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}$_ctbsv( uplo, transn, diag, n, kd, ab, ldab, work,1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ctbrfs
pure module subroutine stdlib${ii}$_ztbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! ZTBRFS provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by ZTBTRS or some other
!! means before entering this routine. ZTBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'ZTBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! compute residual r = b - op(a) * x,
! where op(a) = a, a**t, or a**h, depending on trans.
call stdlib${ii}$_zcopy( n, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1_${ik}$ )
call stdlib${ii}$_zaxpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$_ztbsv( uplo, transt, diag, n, kd, ab, ldab, work,1_${ik}$ )
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}$_ztbsv( uplo, transn, diag, n, kd, ab, ldab, work,1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_ztbrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, ferr,&
!! ZTBRFS: provides error bounds and backward error estimates for the
!! solution to a system of linear equations with a triangular band
!! coefficient matrix.
!! The solution matrix X must be computed by ZTBTRS or some other
!! means before entering this routine. ZTBRFS does not do iterative
!! refinement because doing so cannot improve the backward error.
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) :: diag, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: ab(ldab,*), b(ldb,*), x(ldx,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: notran, nounit, upper
character :: transn, transt
integer(${ik}$) :: 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}$
upper = stdlib_lsame( uplo, 'U' )
notran = stdlib_lsame( trans, 'N' )
nounit = stdlib_lsame( diag, 'N' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( &
trans, 'C' ) ) then
info = -2_${ik}$
else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -6_${ik}$
else if( ldab<kd+1 ) then
info = -8_${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( 'ZTBRFS', -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 = kd + 2_${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_250: do j = 1, nrhs
! 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, x( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$tbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n, -cone, b( 1_${ik}$, j ), 1_${ik}$, 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
if( notran ) then
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) +cabs1( ab( kd+1+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
else
if( nounit ) then
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
end do
else
do k = 1, n
xk = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) +cabs1( ab( 1_${ik}$+i-k, k ) )*xk
end do
rwork( k ) = rwork( k ) + xk
end do
end if
end if
else
! compute abs(a**h)*abs(x) + abs(b).
if( upper ) then
if( nounit ) then
do k = 1, n
s = zero
do i = max( 1, k-kd ), k
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = max( 1, k-kd ), k - 1
s = s + cabs1( ab( kd+1+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
else
if( nounit ) then
do k = 1, n
s = zero
do i = k, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
else
do k = 1, n
s = cabs1( x( k, j ) )
do i = k + 1, min( n, k+kd )
s = s + cabs1( ab( 1_${ik}$+i-k, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
end if
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
! 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}$
210 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}$tbsv( uplo, transt, diag, n, kd, ab, ldab, work,1_${ik}$ )
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}$tbsv( uplo, transn, diag, n, kd, ab, ldab, work,1_${ik}$ )
end if
go to 210
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_250
return
end subroutine stdlib${ii}$_${ci}$tbrfs
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_tri_comp
