#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_chol_comp
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_spocon( uplo, n, a, lda, anorm, rcond, work, iwork,info )
!! SPOCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_slatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_slatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_slatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_slatrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_spocon
pure module subroutine stdlib${ii}$_dpocon( uplo, n, a, lda, anorm, rcond, work, iwork,info )
!! DPOCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_dlatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_dlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_dlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_dlatrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_dpocon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pocon( uplo, n, a, lda, anorm, rcond, work, iwork,info )
!! DPOCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_${ri}$latrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ri}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_${ri}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_${ri}$latrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ri}$pocon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info )
!! CPOCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite matrix using the
!! Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_clatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_clatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_cpocon
pure module subroutine stdlib${ii}$_zpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info )
!! ZPOCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite matrix using the
!! Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_zlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_zlatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_zpocon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pocon( uplo, n, a, lda, anorm, rcond, work, rwork,info )
!! ZPOCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite matrix using the
!! Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
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}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of inv(a).
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_${ci}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_${ci}$latrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,&
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ci}$pocon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spotrf( uplo, n, a, lda, info )
!! SPOTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'SPOTRF', -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}$, 'SPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_spotrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(&
j, j ), lda )
call stdlib${ii}$_spotrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( &
1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda )
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, &
one, a( j, j ), lda,a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_spotrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( &
j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda )
call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, &
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_spotrf
pure module subroutine stdlib${ii}$_dpotrf( uplo, n, a, lda, info )
!! DPOTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'DPOTRF', -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}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_dpotrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(&
j, j ), lda )
call stdlib${ii}$_dpotrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( &
1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda )
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, &
one, a( j, j ), lda,a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_dpotrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( &
j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda )
call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, &
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_dpotrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$potrf( uplo, n, a, lda, info )
!! DPOTRF: computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'DPOTRF', -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}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_${ri}$potrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(&
j, j ), lda )
call stdlib${ii}$_${ri}$potrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( &
1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda )
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, &
one, a( j, j ), lda,a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_${ri}$potrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( &
j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda )
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, &
one, a( j, j ), lda,a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_${ri}$potrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpotrf( uplo, n, a, lda, info )
!! CPOTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'CPOTRF', -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}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_cpotrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), &
lda, one, a( j, j ), lda )
call stdlib${ii}$_cpotrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,&
-cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda )
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, &
n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_cpotrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,&
-cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda )
call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-&
jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_cpotrf
pure module subroutine stdlib${ii}$_zpotrf( uplo, n, a, lda, info )
!! ZPOTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'ZPOTRF', -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}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_zpotrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), &
lda, one, a( j, j ), lda )
call stdlib${ii}$_zpotrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,&
-cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda )
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, &
n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_zpotrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,&
-cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda )
call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-&
jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_zpotrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$potrf( uplo, n, a, lda, info )
!! ZPOTRF: computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j, jb, 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( 'ZPOTRF', -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}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code.
call stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info )
else
! use blocked code.
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), &
lda, one, a( j, j ), lda )
call stdlib${ii}$_${ci}$potrf2( 'UPPER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block row.
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,&
-cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda )
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, &
n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n, nb
! update and factorize the current diagonal block and test
! for non-positive-definiteness.
jb = min( nb, n-j+1 )
call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,&
a( j, j ), lda )
call stdlib${ii}$_${ci}$potrf2( 'LOWER', jb, a( j, j ), lda, info )
if( info/=0 )go to 30
if( j+jb<=n ) then
! compute the current block column.
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,&
-cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda )
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-&
jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda )
end if
end do
end if
end if
go to 40
30 continue
info = info + j - 1_${ik}$
40 continue
return
end subroutine stdlib${ii}$_${ci}$potrf
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_spotrf2( uplo, n, a, lda, info )
!! SPOTRF2 computes the Cholesky factorization of a real symmetric
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then call itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
! 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( 'SPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_sisnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_spotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**t*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), &
lda )
! update and factor a22
call stdlib${ii}$_ssyrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_spotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**t
else
! update and scale a21
call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), &
lda )
! update and factor a22
call stdlib${ii}$_ssyrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_spotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_spotrf2
pure recursive module subroutine stdlib${ii}$_dpotrf2( uplo, n, a, lda, info )
!! DPOTRF2 computes the Cholesky factorization of a real symmetric
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then calls itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
! 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( 'DPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_disnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_dpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**t*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), &
lda )
! update and factor a22
call stdlib${ii}$_dsyrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_dpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**t
else
! update and scale a21
call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), &
lda )
! update and factor a22
call stdlib${ii}$_dsyrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_dpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_dpotrf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ri}$potrf2( uplo, n, a, lda, info )
!! DPOTRF2: computes the Cholesky factorization of a real symmetric
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then calls itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
! 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( 'DPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
if( a( 1_${ik}$, 1_${ik}$ )<=zero.or.stdlib${ii}$_${ri}$isnan( a( 1_${ik}$, 1_${ik}$ ) ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( a( 1_${ik}$, 1_${ik}$ ) )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_${ri}$potrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**t*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ), &
lda )
! update and factor a22
call stdlib${ii}$_${ri}$syrk( uplo, 'T', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**t
else
! update and scale a21
call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ), &
lda )
! update and factor a22
call stdlib${ii}$_${ri}$syrk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$potrf2
#:endif
#:endfor
pure recursive module subroutine stdlib${ii}$_cpotrf2( uplo, n, a, lda, info )
!! CPOTRF2 computes the Cholesky factorization of a Hermitian
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then calls itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
real(sp) :: ajj
! 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( 'CPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_cpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**h*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),&
lda )
! update and factor a22
call stdlib${ii}$_cherk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_cpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**h
else
! update and scale a21
call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),&
lda )
! update and factor a22
call stdlib${ii}$_cherk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_cpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_cpotrf2
pure recursive module subroutine stdlib${ii}$_zpotrf2( uplo, n, a, lda, info )
!! ZPOTRF2 computes the Cholesky factorization of a Hermitian
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then call itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
real(dp) :: ajj
! 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( 'ZPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_zpotrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**h*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),&
lda )
! update and factor a22
call stdlib${ii}$_zherk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_zpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**h
else
! update and scale a21
call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),&
lda )
! update and factor a22
call stdlib${ii}$_zherk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_zpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_zpotrf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure recursive module subroutine stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info )
!! ZPOTRF2: computes the Cholesky factorization of a Hermitian
!! positive definite matrix A using the recursive algorithm.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the recursive version of the algorithm. It divides
!! the matrix into four submatrices:
!! [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
!! A = [ -----|----- ] with n1 = n/2
!! [ A21 | A22 ] n2 = n-n1
!! The subroutine calls itself to factor A11. Update and scale A21
!! or A12, update A22 then call itself to factor A22.
! -- 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) :: 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}$) :: n1, n2, iinfo
real(${ck}$) :: ajj
! 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( 'ZPOTRF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! n=1 case
if( n==1_${ik}$ ) then
! test for non-positive-definiteness
ajj = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
info = 1_${ik}$
return
end if
! factor
a( 1_${ik}$, 1_${ik}$ ) = sqrt( ajj )
! use recursive code
else
n1 = n/2_${ik}$
n2 = n-n1
! factor a11
call stdlib${ii}$_${ci}$potrf2( uplo, n1, a( 1_${ik}$, 1_${ik}$ ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo
return
end if
! compute the cholesky factorization a = u**h*u
if( upper ) then
! update and scale a12
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( 1_${ik}$, n1+1 ),&
lda )
! update and factor a22
call stdlib${ii}$_${ci}$herk( uplo, 'C', n2, n1, -one, a( 1_${ik}$, n1+1 ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
! compute the cholesky factorization a = l*l**h
else
! update and scale a21
call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1_${ik}$, 1_${ik}$ ), lda, a( n1+1, 1_${ik}$ ),&
lda )
! update and factor a22
call stdlib${ii}$_${ci}$herk( uplo, 'N', n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,one, a( n1+1, n1+1 &
), lda )
call stdlib${ii}$_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo )
if ( iinfo/=0_${ik}$ ) then
info = iinfo + n1
return
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$potrf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spotf2( uplo, n, a, lda, info )
!! SPOTF2 computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(sp) :: ajj
! 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( 'SPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_sdot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ )
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_sgemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,&
one, a( j, j+1 ), lda )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_sdot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda )
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),&
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_spotf2
pure module subroutine stdlib${ii}$_dpotf2( uplo, n, a, lda, info )
!! DPOTF2 computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(dp) :: ajj
! 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( 'DPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_ddot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ )
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_dgemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,&
one, a( j, j+1 ), lda )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_ddot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda )
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),&
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_dpotf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$potf2( uplo, n, a, lda, info )
!! DPOTF2: computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(${rk}$) :: ajj
! 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( 'DPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_${ri}$dot( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, j ), 1_${ik}$ )
if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', j-1, n-j, -one, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), 1_${ik}$,&
one, a( j, j+1 ), lda )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = a( j, j ) - stdlib${ii}$_${ri}$dot( j-1, a( j, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda )
if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-j, j-1, -one, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ),&
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_${ri}$potf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpotf2( uplo, n, a, lda, info )
!! CPOTF2 computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(sp) :: ajj
! 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( 'CPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( real( a( j, j ),KIND=sp) - stdlib${ii}$_cdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),&
1_${ik}$ ),KIND=sp)
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), &
1_${ik}$, cone, a( j, j+1 ), lda )
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( real( a( j, j ),KIND=sp) - stdlib${ii}$_cdotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ &
), lda ),KIND=sp)
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )&
, lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_cpotf2
pure module subroutine stdlib${ii}$_zpotf2( uplo, n, a, lda, info )
!! ZPOTF2 computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(dp) :: ajj
! 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( 'ZPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( a( j, j ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),&
1_${ik}$ ),KIND=dp)
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), &
1_${ik}$, cone, a( j, j+1 ), lda )
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( a( j, j ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ &
), lda ),KIND=dp)
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )&
, lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_zpotf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$potf2( uplo, n, a, lda, info )
!! ZPOTF2: computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
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}$) :: j
real(${ck}$) :: ajj
! 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( 'ZPOTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h *u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( a( j, j ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1, a( 1_${ik}$, j ), 1_${ik}$,a( 1_${ik}$, j ),&
1_${ik}$ ),KIND=${ck}$)
if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', j-1, n-j, -cone, a( 1_${ik}$, j+1 ),lda, a( 1_${ik}$, j ), &
1_${ik}$, cone, a( j, j+1 ), lda )
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( a( j, j ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1, a( j, 1_${ik}$ ), lda,a( j, 1_${ik}$ &
), lda ),KIND=${ck}$)
if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ )&
, lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_${ci}$potf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! SPSTRF computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(sp) :: ajj, sstop, stemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'SPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_spstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 200
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj
else
sstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_140: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_130: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_sswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
call stdlib${ii}$_sswap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_sgemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), &
1_${ik}$, one, a( j, j+1 ),lda )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_ssyrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, &
a( j, j ), lda )
end if
end do loop_140
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_180: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_170: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_sswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
call stdlib${ii}$_sswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_sgemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k &
), lda, one,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_170
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_180
end if
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_spstrf
pure module subroutine stdlib${ii}$_dpstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! DPSTRF computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(dp) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'DPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_dpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 200
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_140: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_130: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_dswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
call stdlib${ii}$_dswap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_dgemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), &
1_${ik}$, one, a( j, j+1 ),lda )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_dsyrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, &
a( j, j ), lda )
end if
end do loop_140
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_180: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_170: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_dswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
call stdlib${ii}$_dswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_dgemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k &
), lda, one,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_170
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_180
end if
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_dpstrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! DPSTRF: computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${rk}$), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(${rk}$) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'DPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ri}$pstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 200
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_${ri}$lamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_140: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_130: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ri}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j, j+1 ), lda,a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'TRANS', j-k, n-j, -one, a( k, j+1 ),lda, a( k, j ), &
1_${ik}$, one, a( j, j+1 ),lda )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANS', n-j+1, jb, -one,a( k, j ), lda, one, &
a( j, j ), lda )
end if
end do loop_140
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_180: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first half of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_170: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ri}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ),lda )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'NO TRANS', n-j, j-k, -one,a( j+1, k ), lda, a( j, k &
), lda, one,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_170
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_180
end if
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_${ri}$pstrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! CPSTRF computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(sp) :: ctemp
real(sp) :: ajj, sstop, stemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'CPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_cpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 230
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=sp)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=sp)
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 230
end if
! compute stopping value if not supplied
if( tol<zero ) then
sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj
else
sstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h * u
loop_160: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_150: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),&
KIND=sp)
end if
work( n+i ) = real( a( i, i ),KIND=sp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_cswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
do i = j + 1, pvt - 1
ctemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ctemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),&
1_${ik}$, cone, a( j, j+1 ),lda )
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_cherk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, &
one, a( j, j ), lda )
end if
end do loop_160
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_210: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_200: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),&
KIND=sp)
end if
work( n+i ) = real( a( i, i ),KIND=sp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_cswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
do i = j + 1, pvt - 1
ctemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ctemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_cgemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, &
k ), lda, cone,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_200
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_cherk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_210
end if
end if
! ran to completion, a has full rank
rank = n
go to 230
220 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
230 continue
return
end subroutine stdlib${ii}$_cpstrf
pure module subroutine stdlib${ii}$_zpstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! ZPSTRF computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(dp) :: ztemp
real(dp) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'ZPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_zpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 230
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=dp)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=dp)
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 230
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h * u
loop_160: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_150: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),&
KIND=dp)
end if
work( n+i ) = real( a( i, i ),KIND=dp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_zswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
do i = j + 1, pvt - 1
ztemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ztemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),&
1_${ik}$, cone, a( j, j+1 ),lda )
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_zherk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, &
one, a( j, j ), lda )
end if
end do loop_160
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_210: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_200: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),&
KIND=dp)
end if
work( n+i ) = real( a( i, i ),KIND=dp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_zswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
do i = j + 1, pvt - 1
ztemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ztemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zgemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, &
k ), lda, cone,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_200
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_zherk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_210
end if
end if
! ran to completion, a has full rank
rank = n
go to 230
220 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
230 continue
return
end subroutine stdlib${ii}$_zpstrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pstrf( uplo, n, a, lda, piv, rank, tol, work, info )
!! ZPSTRF: computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${ck}$), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
real(${ck}$), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(${ck}$) :: ztemp
real(${ck}$) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, jb, k, nb, pvt
logical(lk) :: upper
! 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( 'ZPSTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! get block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ .or. nb>=n ) then
! use unblocked code
call stdlib${ii}$_${ci}$pstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info )
go to 230
else
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=${ck}$)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=${ck}$)
if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 230
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h * u
loop_160: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_150: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),&
KIND=${ck}$)
end if
work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ci}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ),&
lda )
do i = j + 1, pvt - 1
ztemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ztemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j.
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'TRANS', j-k, n-j, -cone, a( k, j+1 ),lda, a( k, j ),&
1_${ik}$, cone, a( j, j+1 ),lda )
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJ TRANS', n-j+1, jb, -one,a( k, j ), lda, &
one, a( j, j ), lda )
end if
end do loop_160
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_210: do k = 1, n, nb
! account for last block not being nb wide
jb = min( nb, n-k+1 )
! set relevant part of first chalf of work to zero,
! holds dot products
do i = k, n
work( i ) = 0_${ik}$
end do
loop_200: do j = k, k + jb - 1
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>k ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),&
KIND=${ck}$)
end if
work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 220
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ci}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$,a( pvt+1, pvt ), &
1_${ik}$ )
do i = j + 1, pvt - 1
ztemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ztemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j.
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$gemv( 'NO TRANS', n-j, j-k, -cone,a( j+1, k ), lda, a( j, &
k ), lda, cone,a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_200
! update trailing matrix, j already incremented
if( k+jb<=n ) then
call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANS', n-j+1, jb, -one,a( j, k ), lda, &
one, a( j, j ), lda )
end if
end do loop_210
end if
end if
! ran to completion, a has full rank
rank = n
go to 230
220 continue
! rank is the number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
230 continue
return
end subroutine stdlib${ii}$_${ci}$pstrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! SPSTF2 computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(sp) :: ajj, sstop, stemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'SPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 170
end if
! compute stopping value if not supplied
if( tol<zero ) then
sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj
else
sstop = tol
end if
! set first half of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_130: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_sswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
call stdlib${ii}$_sswap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_sgemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
one, a( j, j+1 ), lda )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_sswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_sswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
call stdlib${ii}$_sswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_sgemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), &
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_150
end if
! ran to completion, a has full rank
rank = n
go to 170
160 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
170 continue
return
end subroutine stdlib${ii}$_spstf2
pure module subroutine stdlib${ii}$_dpstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! DPSTF2 computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(dp) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'DPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 170
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
! set first half of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_130: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_dswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
call stdlib${ii}$_dswap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_dgemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
one, a( j, j+1 ), lda )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_dswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_dswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
call stdlib${ii}$_dswap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_dgemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), &
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_150
end if
! ran to completion, a has full rank
rank = n
go to 170
160 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
170 continue
return
end subroutine stdlib${ii}$_dpstf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! DPSTF2: computes the Cholesky factorization with complete
!! pivoting of a real symmetric positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**T * U , if UPLO = 'U',
!! P**T * A * P = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${rk}$), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
real(${rk}$) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'DPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
pvt = 1_${ik}$
ajj = a( pvt, pvt )
do i = 2, n
if( a( i, i )>ajj ) then
pvt = i
ajj = a( pvt, pvt )
end if
end do
if( ajj<=zero.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 170
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_${ri}$lamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
! set first half of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**t * u
loop_130: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( j-1, i )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ri}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1_${ik}$ )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'TRANS', j-1, n-j, -one, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
one, a( j, j+1 ), lda )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_130
else
! compute the cholesky factorization p**t * a * p = l * l**t
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second half of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) + a( i, j-1 )**2_${ik}$
end if
work( n+i ) = a( i, i ) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${ri}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 160
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ri}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_${ri}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
call stdlib${ii}$_${ri}$swap( pvt-j-1, a( j+1, j ), 1_${ik}$, a( pvt, j+1 ), lda )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_${ri}$gemv( 'NO TRANS', n-j, j-1, -one, a( j+1, 1_${ik}$ ), lda,a( j, 1_${ik}$ ), &
lda, one, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_150
end if
! ran to completion, a has full rank
rank = n
go to 170
160 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
170 continue
return
end subroutine stdlib${ii}$_${ri}$pstf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! CPSTF2 computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(sp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(sp) :: ctemp
real(sp) :: ajj, sstop, stemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'CPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=sp)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=sp)
if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
sstop = n * stdlib${ii}$_slamch( 'EPSILON' ) * ajj
else
sstop = tol
end if
! set first chalf of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h * u
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=sp)
end if
work( n+i ) = real( a( i, i ),KIND=sp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_cswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
do i = j + 1, pvt - 1
ctemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ctemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
cone, a( j, j+1 ), lda )
call stdlib${ii}$_clacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_180: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=sp)
end if
work( n+i ) = real( a( i, i ),KIND=sp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_cswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_cswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
do i = j + 1, pvt - 1
ctemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ctemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
stemp = work( j )
work( j ) = work( pvt )
work( pvt ) = stemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_cgemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), &
lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_csscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_180
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_cpstf2
pure module subroutine stdlib${ii}$_zpstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! ZPSTF2 computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(dp), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(dp) :: ztemp
real(dp) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'ZPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=dp)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=dp)
if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_dlamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
! set first chalf of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h* u
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=dp)
end if
work( n+i ) = real( a( i, i ),KIND=dp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_zswap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
do i = j + 1, pvt - 1
ztemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ztemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
cone, a( j, j+1 ), lda )
call stdlib${ii}$_zlacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_180: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=dp)
end if
work( n+i ) = real( a( i, i ),KIND=dp) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_zswap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_zswap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
do i = j + 1, pvt - 1
ztemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ztemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zgemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), &
lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_zdscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_180
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_zpstf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pstf2( uplo, n, a, lda, piv, rank, tol, work, info )
!! ZPSTF2: computes the Cholesky factorization with complete
!! pivoting of a complex Hermitian positive semidefinite matrix A.
!! The factorization has the form
!! P**T * A * P = U**H * U , if UPLO = 'U',
!! P**T * A * P = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular, and
!! P is stored as vector PIV.
!! This algorithm does not attempt to check that A is positive
!! semidefinite. This version of the algorithm calls level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${ck}$), intent(in) :: tol
integer(${ik}$), intent(out) :: info, rank
integer(${ik}$), intent(in) :: lda, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
real(${ck}$), intent(out) :: work(2_${ik}$*n)
integer(${ik}$), intent(out) :: piv(n)
! =====================================================================
! Local Scalars
complex(${ck}$) :: ztemp
real(${ck}$) :: ajj, dstop, dtemp
integer(${ik}$) :: i, itemp, j, pvt
logical(lk) :: upper
! 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( 'ZPSTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
! initialize piv
do i = 1, n
piv( i ) = i
end do
! compute stopping value
do i = 1, n
work( i ) = real( a( i, i ),KIND=${ck}$)
end do
pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ )
ajj = real( a( pvt, pvt ),KIND=${ck}$)
if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
rank = 0_${ik}$
info = 1_${ik}$
go to 200
end if
! compute stopping value if not supplied
if( tol<zero ) then
dstop = n * stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) * ajj
else
dstop = tol
end if
! set first chalf of work to zero, holds dot products
do i = 1, n
work( i ) = 0_${ik}$
end do
if( upper ) then
! compute the cholesky factorization p**t * a * p = u**h* u
loop_150: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=${ck}$)
end if
work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ci}$swap( j-1, a( 1_${ik}$, j ), 1_${ik}$, a( 1_${ik}$, pvt ), 1_${ik}$ )
if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( j, pvt+1 ), lda,a( pvt, pvt+1 ), lda )
do i = j + 1, pvt - 1
ztemp = conjg( a( j, i ) )
a( j, i ) = conjg( a( i, pvt ) )
a( i, pvt ) = ztemp
end do
a( j, pvt ) = conjg( a( j, pvt ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of row j
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'TRANS', j-1, n-j, -cone, a( 1_${ik}$, j+1 ), lda,a( 1_${ik}$, j ), 1_${ik}$, &
cone, a( j, j+1 ), lda )
call stdlib${ii}$_${ci}$lacgv( j-1, a( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j, j+1 ), lda )
end if
end do loop_150
else
! compute the cholesky factorization p**t * a * p = l * l**h
loop_180: do j = 1, n
! find pivot, test for exit, else swap rows and columns
! update dot products, compute possible pivots which are
! stored in the second chalf of work
do i = j, n
if( j>1_${ik}$ ) then
work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=${ck}$)
end if
work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i )
end do
if( j>1_${ik}$ ) then
itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ )
pvt = itemp + j - 1_${ik}$
ajj = work( n+pvt )
if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then
a( j, j ) = ajj
go to 190
end if
end if
if( j/=pvt ) then
! pivot ok, so can now swap pivot rows and columns
a( pvt, pvt ) = a( j, j )
call stdlib${ii}$_${ci}$swap( j-1, a( j, 1_${ik}$ ), lda, a( pvt, 1_${ik}$ ), lda )
if( pvt<n )call stdlib${ii}$_${ci}$swap( n-pvt, a( pvt+1, j ), 1_${ik}$, a( pvt+1, pvt ),1_${ik}$ )
do i = j + 1, pvt - 1
ztemp = conjg( a( i, j ) )
a( i, j ) = conjg( a( pvt, i ) )
a( pvt, i ) = ztemp
end do
a( pvt, j ) = conjg( a( pvt, j ) )
! swap dot products and piv
dtemp = work( j )
work( j ) = work( pvt )
work( pvt ) = dtemp
itemp = piv( pvt )
piv( pvt ) = piv( j )
piv( j ) = itemp
end if
ajj = sqrt( ajj )
a( j, j ) = ajj
! compute elements j+1:n of column j
if( j<n ) then
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$gemv( 'NO TRANS', n-j, j-1, -cone, a( j+1, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), &
lda, cone, a( j+1, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( j-1, a( j, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, a( j+1, j ), 1_${ik}$ )
end if
end do loop_180
end if
! ran to completion, a has full rank
rank = n
go to 200
190 continue
! rank is number of steps completed. set info = 1 to signal
! that the factorization cannot be used to solve a system.
rank = j - 1_${ik}$
info = 1_${ik}$
200 continue
return
end subroutine stdlib${ii}$_${ci}$pstf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spotrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! SPOTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by SPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a*x = b where a = l*l**t.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
end if
return
end subroutine stdlib${ii}$_spotrs
pure module subroutine stdlib${ii}$_dpotrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! DPOTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a*x = b where a = l*l**t.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_dtrsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
end if
return
end subroutine stdlib${ii}$_dpotrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$potrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! DPOTRS: solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
else
! solve a*x = b where a = l*l**t.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,&
b, ldb )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,&
ldb )
end if
return
end subroutine stdlib${ii}$_${ri}$potrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpotrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! CPOTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H*U or A = L*L**H computed by CPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a*x = b where a = l*l**h.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
end if
return
end subroutine stdlib${ii}$_cpotrs
pure module subroutine stdlib${ii}$_zpotrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! ZPOTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H * U or A = L * L**H computed by ZPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a*x = b where a = l*l**h.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
end if
return
end subroutine stdlib${ii}$_zpotrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info )
!! ZPOTRS: solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H * U or A = L * L**H computed by ZPOTRF.
! -- 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) :: 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) :: upper
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
else
! solve a*x = b where a = l*l**h.
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, &
lda, b, ldb )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,&
a, lda, b, ldb )
end if
return
end subroutine stdlib${ii}$_${ci}$potrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spotri( uplo, n, a, lda, info )
!! SPOTRI computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by SPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'SPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_strtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**t or inv(l)**t * inv(l).
call stdlib${ii}$_slauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_spotri
pure module subroutine stdlib${ii}$_dpotri( uplo, n, a, lda, info )
!! DPOTRI computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'DPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_dtrtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**t or inv(l)**t * inv(l).
call stdlib${ii}$_dlauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_dpotri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$potri( uplo, n, a, lda, info )
!! DPOTRI: computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'DPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ri}$trtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**t or inv(l)**t * inv(l).
call stdlib${ii}$_${ri}$lauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_${ri}$potri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpotri( uplo, n, a, lda, info )
!! CPOTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by CPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'CPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ctrtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**h or inv(l)**h * inv(l).
call stdlib${ii}$_clauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_cpotri
pure module subroutine stdlib${ii}$_zpotri( uplo, n, a, lda, info )
!! ZPOTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'ZPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ztrtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**h or inv(l)**h * inv(l).
call stdlib${ii}$_zlauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_zpotri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$potri( uplo, n, a, lda, info )
!! ZPOTRI: computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPOTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( .not.stdlib_lsame( uplo, 'U' ) .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( 'ZPOTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ci}$trtri( uplo, 'NON-UNIT', n, a, lda, info )
if( info>0 )return
! form inv(u) * inv(u)**h or inv(l)**h * inv(l).
call stdlib${ii}$_${ci}$lauum( uplo, n, a, lda, info )
return
end subroutine stdlib${ii}$_${ci}$potri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! SPORFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_ssymv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( a( k, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( a( k, k ) )*xk
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_spotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_sporfs
pure module subroutine stdlib${ii}$_dporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! DPORFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dsymv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( a( k, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( a( k, k ) )*xk
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_dpotrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dporfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! DPORFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$symv( uplo, n, -one, a, lda, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
do i = 1, k - 1
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( a( k, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( a( k, k ) )*xk
do i = k + 1, n
work( i ) = work( i ) + abs( a( i, k ) )*xk
s = s + abs( a( i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_${ri}$potrs( uplo, n, 1_${ik}$, af, ldaf, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$porfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! CPORFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cporfs
pure module subroutine stdlib${ii}$_zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! ZPORFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zporfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr, &
!! ZPORFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite,
!! and provides error bounds and backward error estimates for the
!! solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPORFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$porfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spoequ( n, a, lda, s, scond, amax, info )
!! SPOEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_spoequ
pure module subroutine stdlib${ii}$_dpoequ( n, a, lda, s, scond, amax, info )
!! DPOEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_dpoequ
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$poequ( n, a, lda, s, scond, amax, info )
!! DPOEQU: computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(out) :: amax, scond
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ri}$poequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpoequ( n, a, lda, s, scond, amax, info )
!! CPOEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(out) :: s(*)
complex(sp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=sp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_cpoequ
pure module subroutine stdlib${ii}$_zpoequ( n, a, lda, s, scond, amax, info )
!! ZPOEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(out) :: s(*)
complex(dp), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=dp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_zpoequ
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$poequ( n, a, lda, s, scond, amax, info )
!! ZPOEQU: computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: amax, scond
! Array Arguments
real(${ck}$), intent(out) :: s(*)
complex(${ck}$), intent(in) :: a(lda,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${ck}$) :: smin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=${ck}$)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ci}$poequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spoequb( n, a, lda, s, scond, amax, info )
!! SPOEQUB computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from SPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_slamch( 'B' )
tmp = -0.5_sp / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_spoequb
pure module subroutine stdlib${ii}$_dpoequb( n, a, lda, s, scond, amax, info )
!! DPOEQUB computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from DPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_dlamch( 'B' )
tmp = -0.5e+0_dp / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_dpoequb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$poequb( n, a, lda, s, scond, amax, info )
!! DPOEQUB: computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from DPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(out) :: amax, scond
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${rk}$) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_${ri}$lamch( 'B' )
tmp = -0.5e+0_${rk}$ / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = a( i, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ri}$poequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpoequb( n, a, lda, s, scond, amax, info )
!! CPOEQUB computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from CPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: amax, scond
! Array Arguments
complex(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(sp) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_slamch( 'B' )
tmp = -0.5_sp / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=sp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_cpoequb
pure module subroutine stdlib${ii}$_zpoequb( n, a, lda, s, scond, amax, info )
!! ZPOEQUB computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from ZPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: amax, scond
! Array Arguments
complex(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(dp) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_dlamch( 'B' )
tmp = -0.5e+0_dp / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=dp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_zpoequb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$poequb( n, a, lda, s, scond, amax, info )
!! ZPOEQUB: computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A and reduce its condition number
!! (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
!! This routine differs from ZPOEQU by restricting the scaling factors
!! to a power of the radix. Barring over- and underflow, scaling by
!! these factors introduces no additional rounding errors. However, the
!! scaled diagonal entries are no longer approximately 1 but lie
!! between sqrt(radix) and 1/sqrt(radix).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: amax, scond
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*)
real(${ck}$), intent(out) :: s(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
real(${ck}$) :: smin, base, tmp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
! positive definite only performs 1 pass of equilibration.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPOEQUB', -info )
return
end if
! quick return if possible.
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
base = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
tmp = -0.5e+0_${ck}$ / log ( base )
! find the minimum and maximum diagonal elements.
s( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
do i = 2, n
s( i ) = real( a( i, i ),KIND=${ck}$)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = base ** int( tmp * log( s( i ) ),KIND=${ik}$)
end do
! compute scond = min(s(i)) / max(s(i)).
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ci}$poequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqhe( uplo, n, a, lda, s, scond, amax, equed )
!! CLAQHE equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: amax, scond
! Array Arguments
real(sp), intent(in) :: s(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
do j = 1, n
cj = s( j )
do i = 1, j - 1
a( i, j ) = cj*s( i )*a( i, j )
end do
a( j, j ) = cj*cj*real( a( j, j ),KIND=sp)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
a( j, j ) = cj*cj*real( a( j, j ),KIND=sp)
do i = j + 1, n
a( i, j ) = cj*s( i )*a( i, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_claqhe
pure module subroutine stdlib${ii}$_zlaqhe( uplo, n, a, lda, s, scond, amax, equed )
!! ZLAQHE equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: amax, scond
! Array Arguments
real(dp), intent(in) :: s(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
do j = 1, n
cj = s( j )
do i = 1, j - 1
a( i, j ) = cj*s( i )*a( i, j )
end do
a( j, j ) = cj*cj*real( a( j, j ),KIND=dp)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
a( j, j ) = cj*cj*real( a( j, j ),KIND=dp)
do i = j + 1, n
a( i, j ) = cj*s( i )*a( i, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_zlaqhe
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed )
!! ZLAQHE: equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: amax, scond
! Array Arguments
real(${ck}$), intent(in) :: s(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
do j = 1, n
cj = s( j )
do i = 1, j - 1
a( i, j ) = cj*s( i )*a( i, j )
end do
a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$)
do i = j + 1, n
a( i, j ) = cj*s( i )*a( i, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_${ci}$laqhe
#:endif
#:endfor
real(sp) module function stdlib${ii}$_sla_porcond( uplo, n, a, lda, af, ldaf, cmode, c,info, work, iwork )
!! SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
! -- 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) :: uplo
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
real(sp), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(sp), intent(out) :: work(*)
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: kase, i, j
real(sp) :: ainvnm, tmp
logical(lk) :: up
! Array Arguments
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_sla_porcond = zero
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLA_PORCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_sla_porcond = one
return
end if
up = .false.
if ( stdlib_lsame( uplo, 'U' ) ) up = .true.
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if ( up ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( j ,i ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
endif
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if (up) then
call stdlib${ii}$_spotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_spotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( up ) then
call stdlib${ii}$_spotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_spotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= 0.0_sp )stdlib${ii}$_sla_porcond = ( one / ainvnm )
return
end function stdlib${ii}$_sla_porcond
real(dp) module function stdlib${ii}$_dla_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork )
!! DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
! -- 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) :: uplo
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
real(dp), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(dp), intent(out) :: work(*)
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: kase, i, j
real(dp) :: ainvnm, tmp
logical(lk) :: up
! Array Arguments
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_dla_porcond = zero
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_PORCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_dla_porcond = one
return
end if
up = .false.
if ( stdlib_lsame( uplo, 'U' ) ) up = .true.
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if ( up ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( j ,i ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
endif
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if (up) then
call stdlib${ii}$_dpotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_dpotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( up ) then
call stdlib${ii}$_dpotrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_dpotrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_dla_porcond = ( one / ainvnm )
return
end function stdlib${ii}$_dla_porcond
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$la_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork )
!! DLA_PORCOND: Estimates the Skeel condition number of op(A) * op2(C)
!! where op2 is determined by CMODE as follows
!! CMODE = 1 op2(C) = C
!! CMODE = 0 op2(C) = I
!! CMODE = -1 op2(C) = inv(C)
!! The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!! is computed by computing scaling factors R such that
!! diag(R)*A*op2(C) is row equilibrated and computing the standard
!! infinity-norm condition number.
! -- 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) :: uplo
integer(${ik}$), intent(in) :: n, lda, ldaf, cmode
integer(${ik}$), intent(out) :: info
real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*)
real(${rk}$), intent(out) :: work(*)
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: kase, i, j
real(${rk}$) :: ainvnm, tmp
logical(lk) :: up
! Array Arguments
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
stdlib${ii}$_${ri}$la_porcond = zero
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLA_PORCOND', -info )
return
end if
if( n==0_${ik}$ ) then
stdlib${ii}$_${ri}$la_porcond = one
return
end if
up = .false.
if ( stdlib_lsame( uplo, 'U' ) ) up = .true.
! compute the equilibration matrix r such that
! inv(r)*a*c has unit 1-norm.
if ( up ) then
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( j, i ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( j ,i ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
else
do i = 1, n
tmp = zero
if ( cmode == 1_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) * c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) * c( j ) )
end do
else if ( cmode == 0_${ik}$ ) then
do j = 1, i
tmp = tmp + abs( a( i, j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) )
end do
else
do j = 1, i
tmp = tmp + abs( a( i, j ) / c( j ) )
end do
do j = i+1, n
tmp = tmp + abs( a( j, i ) / c( j ) )
end do
end if
work( 2_${ik}$*n+i ) = tmp
end do
endif
! estimate the norm of inv(op(a)).
ainvnm = zero
kase = 0_${ik}$
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==2_${ik}$ ) then
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
if (up) then
call stdlib${ii}$_${ri}$potrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_${ri}$potrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by inv(c).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
else
! multiply by inv(c**t).
if ( cmode == 1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) / c( i )
end do
else if ( cmode == -1_${ik}$ ) then
do i = 1, n
work( i ) = work( i ) * c( i )
end do
end if
if ( up ) then
call stdlib${ii}$_${ri}$potrs( 'UPPER', n, 1_${ik}$, af, ldaf, work, n, info )
else
call stdlib${ii}$_${ri}$potrs( 'LOWER', n, 1_${ik}$, af, ldaf, work, n, info )
endif
! multiply by r.
do i = 1, n
work( i ) = work( i ) * work( 2_${ik}$*n+i )
end do
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm /= zero )stdlib${ii}$_${ri}$la_porcond = ( one / ainvnm )
return
end function stdlib${ii}$_${ri}$la_porcond
#:endif
#:endfor
real(sp) module function stdlib${ii}$_sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work )
!! SLA_PORPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
real(sp), intent(in) :: a(lda,*), af(ldaf,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: amax, umax, rpvgrw
logical(lk) :: upper
! Intrinsic Functions
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_sla_porpvgrw = rpvgrw
end function stdlib${ii}$_sla_porpvgrw
real(dp) module function stdlib${ii}$_dla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work )
!! DLA_PORPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
real(dp), intent(in) :: a(lda,*), af(ldaf,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: amax, umax, rpvgrw
logical(lk) :: upper
! Intrinsic Functions
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_dla_porpvgrw = rpvgrw
end function stdlib${ii}$_dla_porpvgrw
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
real(${rk}$) module function stdlib${ii}$_${ri}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work )
!! DLA_PORPVGRW: computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: amax, umax, rpvgrw
logical(lk) :: upper
! Intrinsic Functions
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_${ri}$potrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( abs( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( abs( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_${ri}$la_porpvgrw = rpvgrw
end function stdlib${ii}$_${ri}$la_porpvgrw
#:endif
#:endfor
real(sp) module function stdlib${ii}$_cla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work )
!! CLA_PORPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
complex(sp), intent(in) :: a(lda,*), af(ldaf,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: amax, umax, rpvgrw
logical(lk) :: upper
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= 0.0_sp ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_cla_porpvgrw = rpvgrw
end function stdlib${ii}$_cla_porpvgrw
real(dp) module function stdlib${ii}$_zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work )
!! ZLA_PORPVGRW computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
complex(dp), intent(in) :: a(lda,*), af(ldaf,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: amax, umax, rpvgrw
logical(lk) :: upper
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_zla_porpvgrw = rpvgrw
end function stdlib${ii}$_zla_porpvgrw
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
real(${ck}$) module function stdlib${ii}$_${ci}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work )
!! ZLA_PORPVGRW: computes the reciprocal pivot growth factor
!! norm(A)/norm(U). The "max absolute element" norm is used. If this is
!! much less than 1, the stability of the LU factorization of the
!! (equilibrated) matrix A could be poor. This also means that the
!! solution X, estimated condition numbers, and error bounds could be
!! unreliable.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: ncols, lda, ldaf
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*)
real(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: amax, umax, rpvgrw
logical(lk) :: upper
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
upper = stdlib_lsame( 'UPPER', uplo )
! stdlib${ii}$_${ci}$otrf will have factored only the ncolsxncols leading minor, so
! we restrict the growth search to that minor and use only the first
! 2*ncols workspace entries.
rpvgrw = one
do i = 1, 2*ncols
work( i ) = zero
end do
! find the max magnitude entry of each column.
if ( upper ) then
do j = 1, ncols
do i = 1, j
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( ncols+j ) =max( cabs1( a( i, j ) ), work( ncols+j ) )
end do
end do
end if
! now find the max magnitude entry of each column of the factor in
! af. no pivoting, so no permutations.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do j = 1, ncols
do i = 1, j
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
else
do j = 1, ncols
do i = j, ncols
work( j ) = max( cabs1( af( i, j ) ), work( j ) )
end do
end do
end if
! compute the *inverse* of the max element growth factor. dividing
! by zero would imply the largest entry of the factor's column is
! zero. than can happen when either the column of a is zero or
! massive pivots made the factor underflow to zero. neither counts
! as growth in itself, so simply ignore terms with zero
! denominators.
if ( stdlib_lsame( 'UPPER', uplo ) ) then
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
else
do i = 1, ncols
umax = work( i )
amax = work( ncols+i )
if ( umax /= zero ) then
rpvgrw = min( amax / umax, rpvgrw )
end if
end do
end if
stdlib${ii}$_${ci}$la_porpvgrw = rpvgrw
end function stdlib${ii}$_${ci}$la_porpvgrw
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sppcon( uplo, n, ap, anorm, rcond, work, iwork, info )
!! SPPCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite packed matrix using
!! the Cholesky factorization A = U**T*U or A = L*L**T computed by
!! SPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ap(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_slatps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,&
work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_slatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_slatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_slatps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,&
work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_sppcon
pure module subroutine stdlib${ii}$_dppcon( uplo, n, ap, anorm, rcond, work, iwork, info )
!! DPPCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite packed matrix using
!! the Cholesky factorization A = U**T*U or A = L*L**T computed by
!! DPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ap(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_dlatps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,&
work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_dlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_dlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_dlatps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,&
work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_dppcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ppcon( uplo, n, ap, anorm, rcond, work, iwork, info )
!! DPPCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite packed matrix using
!! the Cholesky factorization A = U**T*U or A = L*L**T computed by
!! DPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_${ri}$latps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,&
work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ri}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, work( 2_${ik}$*n+1 ), info )
else
! multiply by inv(l).
call stdlib${ii}$_${ri}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, work( 2_${ik}$*n+1 ), info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_${ri}$latps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,&
work( 2_${ik}$*n+1 ), info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ri}$ppcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cppcon( uplo, n, ap, anorm, rcond, work, rwork, info )
!! CPPCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite packed matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! CPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_clatps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_clatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_clatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_clatps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_cppcon
pure module subroutine stdlib${ii}$_zppcon( uplo, n, ap, anorm, rcond, work, rwork, info )
!! ZPPCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite packed matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! ZPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_zlatps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_zlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_zlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_zlatps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_zppcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ppcon( uplo, n, ap, anorm, rcond, work, rwork, info )
!! ZPPCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite packed matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! ZPPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_${ci}$latps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ci}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_${ci}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, &
scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_${ci}$latps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, &
work, scaleu, rwork, info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ci}$ppcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spptrf( uplo, n, ap, info )
!! SPPTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(sp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t*u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), &
1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = ap( jj ) - stdlib${ii}$_sdot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l*l**t.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ap( jj )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_sscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_sspr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_spptrf
pure module subroutine stdlib${ii}$_dpptrf( uplo, n, ap, info )
!! DPPTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(dp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t*u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), &
1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = ap( jj ) - stdlib${ii}$_ddot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l*l**t.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ap( jj )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_dscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_dspr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_dpptrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pptrf( uplo, n, ap, info )
!! DPPTRF: computes the Cholesky factorization of a real symmetric
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(${rk}$) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**t*u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), &
1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = ap( jj ) - stdlib${ii}$_${ri}$dot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l*l**t.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ap( jj )
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_${ri}$scal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$spr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_${ri}$pptrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpptrf( uplo, n, ap, info )
!! CPPTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(sp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h * u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, &
ap( jc ), 1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( real( ap( jj ),KIND=sp) - stdlib${ii}$_cdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ &
),KIND=sp)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l * l**h.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ap( jj ),KIND=sp)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_csscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_chpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_cpptrf
pure module subroutine stdlib${ii}$_zpptrf( uplo, n, ap, info )
!! ZPPTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(dp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h * u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, &
ap( jc ), 1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( ap( jj ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ &
),KIND=dp)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l * l**h.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ap( jj ),KIND=dp)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_zdscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_zhpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_zpptrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pptrf( uplo, n, ap, info )
!! ZPPTRF: computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A stored in packed format.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj
real(${ck}$) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
if( upper ) then
! compute the cholesky factorization a = u**h * u.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
! compute elements 1:j-1 of column j.
if( j>1_${ik}$ )call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, &
ap( jc ), 1_${ik}$ )
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( ap( jj ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ &
),KIND=${ck}$)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ap( jj ) = sqrt( ajj )
end do
else
! compute the cholesky factorization a = l * l**h.
jj = 1_${ik}$
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ap( jj ),KIND=${ck}$)
if( ajj<=zero ) then
ap( jj ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ap( jj ) = ajj
! compute elements j+1:n of column j and update the trailing
! submatrix.
if( j<n ) then
call stdlib${ii}$_${ci}$dscal( n-j, one / ajj, ap( jj+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$hpr( 'LOWER', n-j, -one, ap( jj+1 ), 1_${ik}$,ap( jj+n-j+1 ) )
jj = jj + n - j + 1_${ik}$
end if
end do
end if
go to 40
30 continue
info = j
40 continue
return
end subroutine stdlib${ii}$_${ci}$pptrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spptrs( uplo, n, nrhs, ap, b, ldb, info )
!! SPPTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**T*U or A = L*L**T computed by SPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t * u.
do i = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_stpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**t.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_stpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**t *x = y, overwriting b with x.
call stdlib${ii}$_stpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_spptrs
pure module subroutine stdlib${ii}$_dpptrs( uplo, n, nrhs, ap, b, ldb, info )
!! DPPTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**T*U or A = L*L**T computed by DPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t * u.
do i = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_dtpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**t.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_dtpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**t *x = y, overwriting b with x.
call stdlib${ii}$_dtpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_dpptrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pptrs( uplo, n, nrhs, ap, b, ldb, info )
!! DPPTRS: solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**T*U or A = L*L**T computed by DPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t * u.
do i = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**t.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_${ri}$tpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**t *x = y, overwriting b with x.
call stdlib${ii}$_${ri}$tpsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_${ri}$pptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpptrs( uplo, n, nrhs, ap, b, ldb, info )
!! CPPTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**H*U or A = L*L**H computed by CPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h * u.
do i = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ctpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**h.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_ctpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**h *x = y, overwriting b with x.
call stdlib${ii}$_ctpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_cpptrs
pure module subroutine stdlib${ii}$_zpptrs( uplo, n, nrhs, ap, b, ldb, info )
!! ZPPTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**H * U or A = L * L**H computed by ZPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h * u.
do i = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ztpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**h.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_ztpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**h *x = y, overwriting b with x.
call stdlib${ii}$_ztpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_zpptrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pptrs( uplo, n, nrhs, ap, b, ldb, info )
!! ZPPTRS: solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A in packed storage using the Cholesky
!! factorization A = U**H * U or A = L * L**H computed by ZPPTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: i
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h * u.
do i = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
end do
else
! solve a*x = b where a = l * l**h.
do i = 1, nrhs
! solve l*y = b, overwriting b with x.
call stdlib${ii}$_${ci}$tpsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, ap,b( 1_${ik}$, i ), 1_${ik}$ )
! solve l**h *x = y, overwriting b with x.
call stdlib${ii}$_${ci}$tpsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,ap, b( 1_${ik}$, i ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_${ci}$pptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spptri( uplo, n, ap, info )
!! SPPTRI computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by SPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(sp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_stptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**t.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_sspr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = ap( jj )
call stdlib${ii}$_sscal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**t * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = stdlib${ii}$_sdot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ )
if( j<n )call stdlib${ii}$_stpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( &
jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_spptri
pure module subroutine stdlib${ii}$_dpptri( uplo, n, ap, info )
!! DPPTRI computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(dp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_dtptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**t.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_dspr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = ap( jj )
call stdlib${ii}$_dscal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**t * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = stdlib${ii}$_ddot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ )
if( j<n )call stdlib${ii}$_dtpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( &
jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_dpptri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pptri( uplo, n, ap, info )
!! DPPTRI: computes the inverse of a real symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(${rk}$) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ri}$tptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**t.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_${ri}$spr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = ap( jj )
call stdlib${ii}$_${ri}$scal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**t * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = stdlib${ii}$_${ri}$dot( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ )
if( j<n )call stdlib${ii}$_${ri}$tpmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n-j,ap( jjn ), ap( &
jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_${ri}$pptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpptri( uplo, n, ap, info )
!! CPPTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by CPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(sp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ctptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**h.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_chpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = real( ap( jj ),KIND=sp)
call stdlib${ii}$_csscal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**h * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = real( stdlib${ii}$_cdotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=sp)
if( j<n )call stdlib${ii}$_ctpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( &
jjn ), ap( jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_cpptri
pure module subroutine stdlib${ii}$_zpptri( uplo, n, ap, info )
!! ZPPTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(dp) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ztptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**h.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_zhpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = real( ap( jj ),KIND=dp)
call stdlib${ii}$_zdscal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**h * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = real( stdlib${ii}$_zdotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=dp)
if( j<n )call stdlib${ii}$_ztpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( &
jjn ), ap( jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_zpptri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pptri( uplo, n, ap, info )
!! ZPPTRI: computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPPTRF.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, jc, jj, jjn
real(${ck}$) :: ajj
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ci}$tptri( uplo, 'NON-UNIT', n, ap, info )
if( info>0 )return
if( upper ) then
! compute the product inv(u) * inv(u)**h.
jj = 0_${ik}$
do j = 1, n
jc = jj + 1_${ik}$
jj = jj + j
if( j>1_${ik}$ )call stdlib${ii}$_${ci}$hpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap )
ajj = real( ap( jj ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( j, ajj, ap( jc ), 1_${ik}$ )
end do
else
! compute the product inv(l)**h * inv(l).
jj = 1_${ik}$
do j = 1, n
jjn = jj + n - j + 1_${ik}$
ap( jj ) = real( stdlib${ii}$_${ci}$dotc( n-j+1, ap( jj ), 1_${ik}$, ap( jj ), 1_${ik}$ ),KIND=${ck}$)
if( j<n )call stdlib${ii}$_${ci}$tpmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n-j, ap( &
jjn ), ap( jj+1 ), 1_${ik}$ )
jj = jjn
end do
end if
return
end subroutine stdlib${ii}$_${ci}$pptri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! SPPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_sspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_spptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_spprfs
pure module subroutine stdlib${ii}$_dpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! DPPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dspmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_dpptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dpprfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! DPPRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$spmv( uplo, n, -one, ap, x( 1_${ik}$, j ), 1_${ik}$, one, work( n+1 ),1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
ik = kk
do i = 1, k - 1
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ap( kk ) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
work( i ) = work( i ) + abs( ap( ik ) )*xk
s = s + abs( ap( ik ) )*abs( x( i, j ) )
ik = ik + 1_${ik}$
end do
work( k ) = work( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( i )*work( n+i )
end do
call stdlib${ii}$_${ri}$pptrs( uplo, n, 1_${ik}$, afp, work( n+1 ), n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$pprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! CPPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=sp) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=sp) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cpprfs
pure module subroutine stdlib${ii}$_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! ZPPRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=dp) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=dp) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zpprfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, &
!! ZPPRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and packed, and provides error bounds and backward error estimates
!! for the solution.
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) :: 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) :: afp(*), ap(*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! ====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, n, -cone, ap, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
kk = 1_${ik}$
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
ik = kk
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ),KIND=${ck}$) )*xk + s
kk = kk + k
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ap( kk ),KIND=${ck}$) )*xk
ik = kk + 1_${ik}$
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
ik = ik + 1_${ik}$
end do
rwork( k ) = rwork( k ) + s
kk = kk + ( n-k+1 )
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$pprfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sppequ( uplo, n, ap, s, scond, amax, info )
!! SPPEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(sp) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ap( 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_sppequ
pure module subroutine stdlib${ii}$_dppequ( uplo, n, ap, s, scond, amax, info )
!! DPPEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(dp) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ap( 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_dppequ
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ppequ( uplo, n, ap, s, scond, amax, info )
!! DPPEQU: computes row and column scalings intended to equilibrate a
!! symmetric positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(out) :: amax, scond
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(${rk}$) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ap( 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = ap( jj )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ri}$ppequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cppequ( uplo, n, ap, s, scond, amax, info )
!! CPPEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(out) :: s(*)
complex(sp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(sp) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = real( ap( jj ),KIND=sp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = real( ap( jj ),KIND=sp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_cppequ
pure module subroutine stdlib${ii}$_zppequ( uplo, n, ap, s, scond, amax, info )
!! ZPPEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(out) :: s(*)
complex(dp), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(dp) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = real( ap( jj ),KIND=dp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = real( ap( jj ),KIND=dp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_zppequ
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ppequ( uplo, n, ap, s, scond, amax, info )
!! ZPPEQU: computes row and column scalings intended to equilibrate a
!! Hermitian positive definite matrix A in packed storage and reduce
!! its condition number (with respect to the two-norm). S contains the
!! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!! This choice of S puts the condition number of B within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(out) :: amax, scond
! Array Arguments
real(${ck}$), intent(out) :: s(*)
complex(${ck}$), intent(in) :: ap(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, jj
real(${ck}$) :: smin
! 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}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPPEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
if( upper ) then
! uplo = 'u': upper triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + i
s( i ) = real( ap( jj ),KIND=${ck}$)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
else
! uplo = 'l': lower triangle of a is stored.
! find the minimum and maximum diagonal elements.
jj = 1_${ik}$
do i = 2, n
jj = jj + n - i + 2_${ik}$
s( i ) = real( ap( jj ),KIND=${ck}$)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
end if
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ci}$ppequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqhp( uplo, n, ap, s, scond, amax, equed )
!! CLAQHP equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: amax, scond
! Array Arguments
real(sp), intent(in) :: s(*)
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(sp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j - 1
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=sp)
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
ap( jc ) = cj*cj*real( ap( jc ),KIND=sp)
do i = j + 1, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_claqhp
pure module subroutine stdlib${ii}$_zlaqhp( uplo, n, ap, s, scond, amax, equed )
!! ZLAQHP equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: amax, scond
! Array Arguments
real(dp), intent(in) :: s(*)
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(dp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j - 1
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=dp)
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
ap( jc ) = cj*cj*real( ap( jc ),KIND=dp)
do i = j + 1, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_zlaqhp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed )
!! ZLAQHP: equilibrates a Hermitian matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: amax, scond
! Array Arguments
real(${ck}$), intent(in) :: s(*)
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j, jc
real(${ck}$) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j - 1
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=${ck}$)
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
ap( jc ) = cj*cj*real( ap( jc ),KIND=${ck}$)
do i = j + 1, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_${ci}$laqhp
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spftrf( transr, uplo, n, a, info )
!! SPFTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPFTRF', -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}$_spotrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_ssyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_spotrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$_spotrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_ssyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_spotrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_spotrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_ssyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_spotrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_spotrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_ssyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_spotrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$_spotrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_ssyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_spotrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_spotrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_ssyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_spotrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_spotrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_ssyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_spotrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$_spotrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k &
)
call stdlib${ii}$_ssyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_spotrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_spftrf
pure module subroutine stdlib${ii}$_dpftrf( transr, uplo, n, a, info )
!! DPFTRF computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRF', -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}$_dpotrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_dsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_dpotrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$_dpotrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_dsyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_dpotrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_dpotrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_dsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_dpotrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_dpotrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_dsyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_dpotrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$_dpotrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_dsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_dpotrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_dpotrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_dsyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_dpotrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_dpotrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_dsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_dpotrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$_dpotrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k &
)
call stdlib${ii}$_dsyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_dpotrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_dpftrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pftrf( transr, uplo, n, a, info )
!! DPFTRF: computes the Cholesky factorization of a real symmetric
!! positive definite matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRF', -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}$potrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_${ri}$syrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_${ri}$potrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$potrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ri}$syrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_${ri}$potrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 't'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_${ri}$potrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_${ri}$syrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_${ri}$potrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_${ri}$potrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_${ri}$syrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_${ri}$potrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$potrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_${ri}$syrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ri}$potrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$potrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ri}$syrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_${ri}$potrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$potrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_${ri}$syrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_${ri}$potrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$potrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_${ri}$trsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k &
)
call stdlib${ii}$_${ri}$syrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_${ri}$potrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$pftrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpftrf( transr, uplo, n, a, info )
!! CPFTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPFTRF', -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}$_cpotrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_cherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_cpotrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$_cpotrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_cherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_cpotrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_cpotrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_cherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_cpotrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_cpotrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_cherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_cpotrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$_cpotrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_cherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_cpotrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_cpotrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_cherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_cpotrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_cpotrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_cherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_cpotrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$_cpotrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_cherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_cpotrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_cpftrf
pure module subroutine stdlib${ii}$_zpftrf( transr, uplo, n, a, info )
!! ZPFTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRF', -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}$_zpotrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_zherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_zpotrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$_zpotrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_zherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_zpotrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_zpotrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_zherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_zpotrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_zpotrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_zherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_zpotrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$_zpotrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_zherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_zpotrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_zpotrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_zherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_zpotrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$_zpotrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_zherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_zpotrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$_zpotrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_zherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_zpotrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_zpftrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pftrf( transr, uplo, n, a, info )
!! ZPFTRF: computes the Cholesky factorization of a complex Hermitian
!! positive definite matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
!! This is the block version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: transr, uplo
integer(${ik}$), intent(in) :: n
integer(${ik}$), intent(out) :: info
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRF', -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}$potrf( 'L', n1, a( 0_${ik}$ ), n, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n )
call stdlib${ii}$_${ci}$herk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n )
call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n ), n, info )
if( info>0_${ik}$ )info = info + n1
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}$potrf( 'L', n1, a( n2 ), n, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ci}$herk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n )
call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n1 ), n, info )
if( info>0_${ik}$ )info = info + n1
end if
else
! n is odd and transr = 'c'
if( lower ) then
! srpa for lower, transpose and n is odd
! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1)
! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1
call stdlib${ii}$_${ci}$potrf( 'U', n1, a( 0_${ik}$ ), n1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_${ci}$herk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 )
call stdlib${ii}$_${ci}$potrf( 'L', n2, a( 1_${ik}$ ), n1, info )
if( info>0_${ik}$ )info = info + n1
else
! srpa for upper, transpose and n is odd
! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0)
! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2
call stdlib${ii}$_${ci}$potrf( 'U', n1, a( n2*n2 ), n2, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_${ci}$herk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 )
call stdlib${ii}$_${ci}$potrf( 'L', n2, a( n1*n2 ), n2, info )
if( info>0_${ik}$ )info = info + n1
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}$potrf( 'L', k, a( 1_${ik}$ ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ci}$potrf( 'U', k, a( 0_${ik}$ ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$potrf( 'L', k, a( k+1 ), n+1, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 )
call stdlib${ii}$_${ci}$potrf( 'U', k, a( k ), n+1, info )
if( info>0_${ik}$ )info = info + k
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}$potrf( 'U', k, a( 0_${ik}$+k ), k, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k )
call stdlib${ii}$_${ci}$potrf( 'L', k, a( 0_${ik}$ ), k, info )
if( info>0_${ik}$ )info = info + 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}$potrf( 'U', k, a( k*( k+1 ) ), k, info )
if( info>0 )return
call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), &
k )
call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k )
call stdlib${ii}$_${ci}$potrf( 'L', k, a( k*k ), k, info )
if( info>0_${ik}$ )info = info + k
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$pftrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! SPFTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by SPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: a(0_${ik}$:*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
else
call stdlib${ii}$_stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_spftrs
pure module subroutine stdlib${ii}$_dpftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! DPFTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: a(0_${ik}$:*)
real(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
else
call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_dpftrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! DPFTRS: solves a system of linear equations A*X = B with a symmetric
!! positive definite matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(in) :: a(0_${ik}$:*)
real(${rk}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
else
call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb )
call stdlib${ii}$_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_${ri}$pftrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! CPFTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H*U or A = L*L**H computed by CPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(sp), intent(in) :: a(0_${ik}$:*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
else
call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_cpftrs
pure module subroutine stdlib${ii}$_zpftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! ZPFTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H*U or A = L*L**H computed by ZPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(dp), intent(in) :: a(0_${ik}$:*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
else
call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_zpftrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info )
!! ZPFTRS: solves a system of linear equations A*X = B with a Hermitian
!! positive definite matrix A using the Cholesky factorization
!! A = U**H*U or A = L*L**H computed by ZPFTRF.
! -- 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
complex(${ck}$), intent(in) :: a(0_${ik}$:*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, normaltransr
! 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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! start execution: there are two triangular solves
if( lower ) then
call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
else
call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb )
call stdlib${ii}$_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb )
end if
return
end subroutine stdlib${ii}$_${ci}$pftrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spftri( transr, uplo, n, a, info )
!! SPFTRI computes the inverse of a real (symmetric) positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by SPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_stftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$_slauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_ssyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n )
call stdlib${ii}$_slauum( 'U', n2, a( n ), n, info )
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}$_slauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_ssyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_slauum( 'U', n2, a( n1 ), n, info )
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}$_slauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_ssyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_slauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$_slauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_ssyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_slauum( 'L', n2, a( n1*n2 ), n2, info )
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}$_slauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_ssyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_slauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$_slauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_ssyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_slauum( 'U', k, a( k ), n+1, info )
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}$_slauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_ssyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k &
)
call stdlib${ii}$_slauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$_slauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_ssyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_slauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_spftri
pure module subroutine stdlib${ii}$_dpftri( transr, uplo, n, a, info )
!! DPFTRI computes the inverse of a (real) symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_dtftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$_dlauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_dsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n )
call stdlib${ii}$_dlauum( 'U', n2, a( n ), n, info )
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}$_dlauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_dsyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_dlauum( 'U', n2, a( n1 ), n, info )
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}$_dlauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_dsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_dlauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$_dlauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_dsyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_dlauum( 'L', n2, a( n1*n2 ), n2, info )
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}$_dlauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_dsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_dlauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$_dlauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_dsyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_dlauum( 'U', k, a( k ), n+1, info )
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}$_dlauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_dsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k &
)
call stdlib${ii}$_dlauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$_dlauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_dsyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_dlauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_dpftri
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pftri( transr, uplo, n, a, info )
!! DPFTRI: computes the inverse of a (real) symmetric positive definite
!! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!! computed by DPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ri}$tftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$lauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_${ri}$syrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n )
call stdlib${ii}$_${ri}$lauum( 'U', n2, a( n ), n, info )
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}$lauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_${ri}$syrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ri}$lauum( 'U', n2, a( n1 ), n, info )
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}$lauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_${ri}$syrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 &
)
call stdlib${ii}$_${ri}$lauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$lauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_${ri}$syrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 &
)
call stdlib${ii}$_${ri}$lauum( 'L', n2, a( n1*n2 ), n2, info )
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}$lauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_${ri}$syrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_${ri}$lauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$lauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_${ri}$syrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ri}$lauum( 'U', k, a( k ), n+1, info )
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}$lauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_${ri}$syrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_${ri}$trmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k &
)
call stdlib${ii}$_${ri}$lauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$lauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_${ri}$syrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_${ri}$lauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$pftri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpftri( transr, uplo, n, a, info )
!! CPFTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by CPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ctftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$_clauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_cherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n )
call stdlib${ii}$_clauum( 'U', n2, a( n ), n, info )
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}$_clauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_cherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_clauum( 'U', n2, a( n1 ), n, info )
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}$_clauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_cherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_clauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$_clauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_cherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_clauum( 'L', n2, a( n1*n2 ), n2, info )
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}$_clauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_cherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_clauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$_clauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_cherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_clauum( 'U', k, a( k ), n+1, info )
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}$_clauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_cherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_clauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$_clauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_cherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_clauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_cpftri
pure module subroutine stdlib${ii}$_zpftri( transr, uplo, n, a, info )
!! ZPFTRI computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_ztftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$_zlauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_zherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n )
call stdlib${ii}$_zlauum( 'U', n2, a( n ), n, info )
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}$_zlauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_zherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_zlauum( 'U', n2, a( n1 ), n, info )
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}$_zlauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_zherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_zlauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$_zlauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_zherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_zlauum( 'L', n2, a( n1*n2 ), n2, info )
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}$_zlauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_zherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_zlauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$_zlauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_zherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_zlauum( 'U', k, a( k ), n+1, info )
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}$_zlauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_zherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_zlauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$_zlauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_zherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_zlauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_zpftri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pftri( transr, uplo, n, a, info )
!! ZPFTRI: computes the inverse of a complex Hermitian positive definite
!! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!! computed by ZPFTRF.
! -- 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
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( n<0_${ik}$ ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPFTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! invert the triangular cholesky factor u or l.
call stdlib${ii}$_${ci}$tftri( transr, uplo, 'N', n, a, info )
if( info>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 of triangular matrix multiply: inv(u)*inv(u)^c or
! inv(l)^c*inv(l). 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}$lauum( 'L', n1, a( 0_${ik}$ ), n, info )
call stdlib${ii}$_${ci}$herk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n )
call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n ), n, info )
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}$lauum( 'L', n1, a( n2 ), n, info )
call stdlib${ii}$_${ci}$herk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n )
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n )
call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n1 ), n, info )
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}$lauum( 'U', n1, a( 0_${ik}$ ), n1, info )
call stdlib${ii}$_${ci}$herk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 )
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), &
n1 )
call stdlib${ii}$_${ci}$lauum( 'L', n2, a( 1_${ik}$ ), n1, info )
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}$lauum( 'U', n1, a( n2*n2 ), n2, info )
call stdlib${ii}$_${ci}$herk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 )
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), &
n2 )
call stdlib${ii}$_${ci}$lauum( 'L', n2, a( n1*n2 ), n2, info )
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}$lauum( 'L', k, a( 1_${ik}$ ), n+1, info )
call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 )
call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 )
call stdlib${ii}$_${ci}$lauum( 'U', k, a( 0_${ik}$ ), n+1, info )
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}$lauum( 'L', k, a( k+1 ), n+1, info )
call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 )
call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 )
call stdlib${ii}$_${ci}$lauum( 'U', k, a( k ), n+1, info )
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}$lauum( 'U', k, a( k ), k, info )
call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k )
call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), &
k )
call stdlib${ii}$_${ci}$lauum( 'L', k, a( 0_${ik}$ ), k, info )
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}$lauum( 'U', k, a( k*( k+1 ) ), k, info )
call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k )
call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k )
call stdlib${ii}$_${ci}$lauum( 'L', k, a( k*k ), k, info )
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$pftri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info )
!! SPBCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite band matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_slatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_slatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(l).
call stdlib${ii}$_slatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_slatbs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_srscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_spbcon
pure module subroutine stdlib${ii}$_dpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info )
!! DPBCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite band matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_dlatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_dlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(l).
call stdlib${ii}$_dlatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_dlatbs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_dpbcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info )
!! DPBCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite band matrix using the
!! Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${rk}$), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**t).
call stdlib${ii}$_${ri}$latbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ri}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
else
! multiply by inv(l).
call stdlib${ii}$_${ri}$latbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, work( 2_${ik}$*n+1 ),info )
normin = 'Y'
! multiply by inv(l**t).
call stdlib${ii}$_${ri}$latbs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, work( 2_${ik}$*n+1 ),info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
if( scale<abs( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ri}$rscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ri}$pbcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info )
!! CPBCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite band matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! CPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(sp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_clatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scalel, rwork,info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_clatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_clatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_clatbs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scaleu, rwork,info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_cpbcon
pure module subroutine stdlib${ii}$_zpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info )
!! ZPBCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite band matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! ZPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(dp) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_zlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scalel, rwork,info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_zlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_zlatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_zlatbs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scaleu, rwork,info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_zpbcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info )
!! ZPBCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite band matrix using
!! the Cholesky factorization A = U**H*U or A = L*L**H computed by
!! ZPBTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${ck}$), intent(in) :: anorm
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) :: upper
character :: normin
integer(${ik}$) :: ix, kase
real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum
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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
normin = 'N'
10 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
if( upper ) then
! multiply by inv(u**h).
call stdlib${ii}$_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scalel, rwork,info )
normin = 'Y'
! multiply by inv(u).
call stdlib${ii}$_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scaleu, rwork, info )
else
! multiply by inv(l).
call stdlib${ii}$_${ci}$latbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, &
work, scalel, rwork, info )
normin = 'Y'
! multiply by inv(l**h).
call stdlib${ii}$_${ci}$latbs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,&
ldab, work, scaleu, rwork,info )
end if
! multiply by 1/scale if doing so will not cause overflow.
scale = scalel*scaleu
if( scale/=one ) then
ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ )
if( scale<cabs1( work( ix ) )*smlnum .or. scale==zero )go to 20
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 10
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
20 continue
return
end subroutine stdlib${ii}$_${ci}$pbcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbtrf( uplo, n, kd, ab, ldab, info )
!! SPBTRF computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
real(sp) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPBTRF', -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}$, 'SPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_spbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a symmetric band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_spotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,&
ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib &
), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,&
ab( kd+1, i ),ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -&
one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1_${ik}$+ib, i+kd ), &
ldab-1 )
! update a33
call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,&
ab( kd+1, i+kd ),ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a symmetric band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_spotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, &
one, ab( 1_${ik}$, i ),ldab-1, ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, &
one, ab( 1_${ik}$, i ),ldab-1, work, ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -&
one, work, ldwork,ab( 1_${ik}$+ib, i ), ldab-1, one,ab( 1_${ik}$+kd-ib, i+ib ), ldab-&
1_${ik}$ )
! update a33
call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_spbtrf
pure module subroutine stdlib${ii}$_dpbtrf( uplo, n, kd, ab, ldab, info )
!! DPBTRF computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
real(dp) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTRF', -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}$, 'DPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_dpbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a symmetric band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_dpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,&
ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib &
), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,&
ab( kd+1, i ),ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -&
one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1_${ik}$+ib, i+kd ), &
ldab-1 )
! update a33
call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,&
ab( kd+1, i+kd ),ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a symmetric band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_dpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, &
one, ab( 1_${ik}$, i ),ldab-1, ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, &
one, ab( 1_${ik}$, i ),ldab-1, work, ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -&
one, work, ldwork,ab( 1_${ik}$+ib, i ), ldab-1, one,ab( 1_${ik}$+kd-ib, i+ib ), ldab-&
1_${ik}$ )
! update a33
call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_dpbtrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbtrf( uplo, n, kd, ab, ldab, info )
!! DPBTRF: computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U, if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(${rk}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
real(${rk}$) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTRF', -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}$, 'DPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_${ri}$pbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a symmetric band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_${ri}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,&
ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib &
), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,&
ab( kd+1, i ),ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -&
one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1_${ik}$+ib, i+kd ), &
ldab-1 )
! update a33
call stdlib${ii}$_${ri}$syrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,&
ab( kd+1, i+kd ),ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a symmetric band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_${ri}$potf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, &
one, ab( 1_${ik}$, i ),ldab-1, ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, &
one, ab( 1_${ik}$, i ),ldab-1, work, ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -&
one, work, ldwork,ab( 1_${ik}$+ib, i ), ldab-1, one,ab( 1_${ik}$+kd-ib, i+ib ), ldab-&
1_${ik}$ )
! update a33
call stdlib${ii}$_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_${ri}$pbtrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbtrf( uplo, n, kd, ab, ldab, info )
!! CPBTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
complex(sp) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPBTRF', -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}$, 'CPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_cpbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a hermitian band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_cpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+&
1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, &
i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, &
i+kd ),ldab-1 )
! update a33
call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, &
ldwork, one,ab( kd+1, i+kd ), ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a hermitian band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_cpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, &
i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+&
ib ),ldab-1 )
! update a33
call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_cpbtrf
pure module subroutine stdlib${ii}$_zpbtrf( uplo, n, kd, ab, ldab, info )
!! ZPBTRF computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
complex(dp) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTRF', -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}$, 'ZPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_zpbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a hermitian band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_zpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+&
1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, &
i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, &
i+kd ),ldab-1 )
! update a33
call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, &
ldwork, one,ab( kd+1, i+kd ), ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a hermitian band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_zpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, &
i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+&
ib ),ldab-1 )
! update a33
call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_zpbtrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbtrf( uplo, n, kd, ab, ldab, info )
!! ZPBTRF: computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U, if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix and L is lower triangular.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmax = 32_${ik}$
integer(${ik}$), parameter :: ldwork = nbmax+1
! Local Scalars
integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb
! Local Arrays
complex(${ck}$) :: work(ldwork,nbmax)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( ( .not.stdlib_lsame( uplo, 'U' ) ) .and.( .not.stdlib_lsame( uplo, 'L' ) ) ) &
then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTRF', -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}$, 'ZPBTRF', uplo, n, kd, -1_${ik}$, -1_${ik}$ )
! the block size must not exceed the semi-bandwidth kd, and must not
! exceed the limit set by the size of the local array work.
nb = min( nb, nbmax )
if( nb<=1_${ik}$ .or. nb>kd ) then
! use unblocked code
call stdlib${ii}$_${ci}$pbtf2( uplo, n, kd, ab, ldab, info )
else
! use blocked code
if( stdlib_lsame( uplo, 'U' ) ) then
! compute the cholesky factorization of a hermitian band
! matrix, given the upper triangle of the matrix in band
! storage.
! zero the upper triangle of the work array.
do j = 1, nb
do i = 1, j - 1
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_70: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_${ci}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11 a12 a13
! a22 a23
! a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a12, a22 and
! a23 are empty if ib = kd. the upper triangle of a13
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a12
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 )
! update a22
call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+&
1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the lower triangle of a13 into the work array.
do jj = 1, i3
do ii = jj, ib
work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
end do
end do
! update a13 (in the work array).
call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', &
ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork )
! update a23
if( i2>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, &
i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, &
i+kd ),ldab-1 )
! update a33
call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, &
ldwork, one,ab( kd+1, i+kd ), ldab-1 )
! copy the lower triangle of a13 back into place.
do jj = 1, i3
do ii = jj, ib
ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_70
else
! compute the cholesky factorization of a hermitian band
! matrix, given the lower triangle of the matrix in band
! storage.
! zero the lower triangle of the work array.
do j = 1, nb
do i = j + 1, nb
work( i, j ) = zero
end do
end do
! process the band matrix one diagonal block at a time.
loop_140: do i = 1, n, nb
ib = min( nb, n-i+1 )
! factorize the diagonal block
call stdlib${ii}$_${ci}$potf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii )
if( ii/=0_${ik}$ ) then
info = i + ii - 1_${ik}$
go to 150
end if
if( i+ib<=n ) then
! update the relevant part of the trailing submatrix.
! if a11 denotes the diagonal block which has just been
! factorized, then we need to update the remaining
! blocks in the diagram:
! a11
! a21 a22
! a31 a32 a33
! the numbers of rows and columns in the partitioning
! are ib, i2, i3 respectively. the blocks a21, a22 and
! a32 are empty if ib = kd. the lower triangle of a31
! lies outside the band.
i2 = min( kd-ib, n-i-ib+1 )
i3 = min( ib, n-i-kd+1 )
if( i2>0_${ik}$ ) then
! update a21
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 )
! update a22
call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), &
ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 )
end if
if( i3>0_${ik}$ ) then
! copy the upper triangle of a31 into the work array.
do jj = 1, ib
do ii = 1, min( jj, i3 )
work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
end do
end do
! update a31 (in the work array).
call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', &
i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork )
! update a32
if( i2>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, &
i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+&
ib ),ldab-1 )
! update a33
call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, &
one, ab( 1_${ik}$, i+kd ),ldab-1 )
! copy the upper triangle of a31 back into place.
do jj = 1, ib
do ii = 1, min( jj, i3 )
ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
end do
end do
end if
end if
end do loop_140
end if
end if
return
150 continue
return
end subroutine stdlib${ii}$_${ci}$pbtrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbtf2( uplo, n, kd, ab, ldab, info )
!! SPBTF2 computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix, U**T is the transpose of U, and
!! L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(sp) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = ab( kd+1, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_sscal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_ssyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ab( 1_${ik}$, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_sscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_ssyr( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_spbtf2
pure module subroutine stdlib${ii}$_dpbtf2( uplo, n, kd, ab, ldab, info )
!! DPBTF2 computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix, U**T is the transpose of U, and
!! L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(dp) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = ab( kd+1, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_dscal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_dsyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ab( 1_${ik}$, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_dscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_dsyr( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_dpbtf2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbtf2( uplo, n, kd, ab, ldab, info )
!! DPBTF2: computes the Cholesky factorization of a real symmetric
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**T * U , if UPLO = 'U', or
!! A = L * L**T, if UPLO = 'L',
!! where U is an upper triangular matrix, U**T is the transpose of U, and
!! L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
real(${rk}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(${rk}$) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**t*u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = ab( kd+1, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_${ri}$syr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**t.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = ab( 1_${ik}$, j )
if( ajj<=zero )go to 30
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ri}$syr( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_${ri}$pbtf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbtf2( uplo, n, kd, ab, ldab, info )
!! CPBTF2 computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix, U**H is the conjugate transpose
!! of U, and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(sp) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**h * u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( ab( kd+1, j ),KIND=sp)
if( ajj<=zero ) then
ab( kd+1, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_csscal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_clacgv( kn, ab( kd, j+1 ), kld )
call stdlib${ii}$_cher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
call stdlib${ii}$_clacgv( kn, ab( kd, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ab( 1_${ik}$, j ),KIND=sp)
if( ajj<=zero ) then
ab( 1_${ik}$, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_csscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_cher( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_cpbtf2
pure module subroutine stdlib${ii}$_zpbtf2( uplo, n, kd, ab, ldab, info )
!! ZPBTF2 computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix, U**H is the conjugate transpose
!! of U, and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(dp) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**h * u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( ab( kd+1, j ),KIND=dp)
if( ajj<=zero ) then
ab( kd+1, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_zdscal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_zlacgv( kn, ab( kd, j+1 ), kld )
call stdlib${ii}$_zher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
call stdlib${ii}$_zlacgv( kn, ab( kd, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ab( 1_${ik}$, j ),KIND=dp)
if( ajj<=zero ) then
ab( 1_${ik}$, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_zdscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zher( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_zpbtf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbtf2( uplo, n, kd, ab, ldab, info )
!! ZPBTF2: computes the Cholesky factorization of a complex Hermitian
!! positive definite band matrix A.
!! The factorization has the form
!! A = U**H * U , if UPLO = 'U', or
!! A = L * L**H, if UPLO = 'L',
!! where U is an upper triangular matrix, U**H is the conjugate transpose
!! of U, and L is lower triangular.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
! Array Arguments
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, kld, kn
real(${ck}$) :: ajj
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTF2', -info )
return
end if
! quick return if possible
if( n==0 )return
kld = max( 1_${ik}$, ldab-1 )
if( upper ) then
! compute the cholesky factorization a = u**h * u.
do j = 1, n
! compute u(j,j) and test for non-positive-definiteness.
ajj = real( ab( kd+1, j ),KIND=${ck}$)
if( ajj<=zero ) then
ab( kd+1, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( kd+1, j ) = ajj
! compute elements j+1:j+kn of row j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_${ci}$dscal( kn, one / ajj, ab( kd, j+1 ), kld )
call stdlib${ii}$_${ci}$lacgv( kn, ab( kd, j+1 ), kld )
call stdlib${ii}$_${ci}$her( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld )
call stdlib${ii}$_${ci}$lacgv( kn, ab( kd, j+1 ), kld )
end if
end do
else
! compute the cholesky factorization a = l*l**h.
do j = 1, n
! compute l(j,j) and test for non-positive-definiteness.
ajj = real( ab( 1_${ik}$, j ),KIND=${ck}$)
if( ajj<=zero ) then
ab( 1_${ik}$, j ) = ajj
go to 30
end if
ajj = sqrt( ajj )
ab( 1_${ik}$, j ) = ajj
! compute elements j+1:j+kn of column j and update the
! trailing submatrix within the band.
kn = min( kd, n-j )
if( kn>0_${ik}$ ) then
call stdlib${ii}$_${ci}$dscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$her( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld )
end if
end do
end if
return
30 continue
info = j
return
end subroutine stdlib${ii}$_${ci}$pbtf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! SPBTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite band matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by SPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
do j = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**t.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_stbsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_spbtrs
pure module subroutine stdlib${ii}$_dpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! DPBTRS solves a system of linear equations A*X = B with a symmetric
!! positive definite band matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
do j = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**t.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_dtbsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_dpbtrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! DPBTRS: solves a system of linear equations A*X = B with a symmetric
!! positive definite band matrix A using the Cholesky factorization
!! A = U**T*U or A = L*L**T computed by DPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**t *u.
do j = 1, nrhs
! solve u**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**t.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**t *x = b, overwriting b with x.
call stdlib${ii}$_${ri}$tbsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j ), &
1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_${ri}$pbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! CPBTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite band matrix A using the Cholesky factorization
!! A = U**H*U or A = L*L**H computed by CPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
do j = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**h.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_ctbsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_cpbtrs
pure module subroutine stdlib${ii}$_zpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! ZPBTRS solves a system of linear equations A*X = B with a Hermitian
!! positive definite band matrix A using the Cholesky factorization
!! A = U**H *U or A = L*L**H computed by ZPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
do j = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**h.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_ztbsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_zpbtrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info )
!! ZPBTRS: solves a system of linear equations A*X = B with a Hermitian
!! positive definite band matrix A using the Cholesky factorization
!! A = U**H *U or A = L*L**H computed by ZPBTRF.
! -- 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) :: 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) :: upper
integer(${ik}$) :: j
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b where a = u**h *u.
do j = 1, nrhs
! solve u**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
! solve u*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
end do
else
! solve a*x = b where a = l*l**h.
do j = 1, nrhs
! solve l*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1_${ik}$, j )&
, 1_${ik}$ )
! solve l**h *x = b, overwriting b with x.
call stdlib${ii}$_${ci}$tbsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(&
1_${ik}$, j ), 1_${ik}$ )
end do
end if
return
end subroutine stdlib${ii}$_${ci}$pbtrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! SPBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'SPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_scopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_ssbmv( uplo, n, kd, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( ab( kd+1, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ab( 1_${ik}$, k ) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_spbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_slacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_spbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_spbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_spbrfs
pure module subroutine stdlib${ii}$_dpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! DPBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'DPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_dcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_dsbmv( uplo, n, kd, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( ab( kd+1, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ab( 1_${ik}$, k ) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_dlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_dlacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_dpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_dpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_dpbrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! DPBRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, iwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'DPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ri}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work( n+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$sbmv( uplo, n, kd, -one, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, one,work( n+1 ), 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
work( i ) = abs( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = abs( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + abs( ab( kd+1, k ) )*xk + s
end do
else
do k = 1, n
s = zero
xk = abs( x( k, j ) )
work( k ) = work( k ) + abs( ab( 1_${ik}$, k ) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
end do
work( k ) = work( k ) + s
end do
end if
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( work( i )>safe2 ) then
work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
else
work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ri}$lacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**t).
call stdlib${ii}$_${ri}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( n+i ) = work( n+i )*work( i )
end do
call stdlib${ii}$_${ri}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work( n+1 ), n,info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, abs( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ri}$pbrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! CPBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'CPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chbmv( uplo, n, kd, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, cone,work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( ab( kd+1, k ),KIND=sp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ab( 1_${ik}$, k ),KIND=sp) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cpbrfs
pure module subroutine stdlib${ii}$_zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! ZPBRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'ZPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhbmv( uplo, n, kd, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, cone,work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( ab( kd+1, k ),KIND=dp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ab( 1_${ik}$, k ),KIND=dp) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zpbrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, &
!! ZPBRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and banded, and provides error bounds and backward error estimates
!! for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, l, 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' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldafb<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( 'ZPBRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = min( n+1, 2_${ik}$*kd+2 )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hbmv( uplo, n, kd, -cone, ab, ldab, x( 1_${ik}$, j ), 1_${ik}$, cone,work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
l = kd + 1_${ik}$ - k
do i = max( 1, k-kd ), k - 1
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( ab( kd+1, k ),KIND=${ck}$) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( ab( 1_${ik}$, k ),KIND=${ck}$) )*xk
l = 1_${ik}$ - k
do i = k + 1, min( n, k+kd )
rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$pbrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! SPBEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(in) :: ab(ldab,*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(sp) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ab( j, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = ab( j, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_spbequ
pure module subroutine stdlib${ii}$_dpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! DPBEQU computes row and column scalings intended to equilibrate a
!! symmetric positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(in) :: ab(ldab,*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(dp) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ab( j, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = ab( j, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_dpbequ
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! DPBEQU: computes row and column scalings intended to equilibrate a
!! symmetric positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${rk}$), intent(out) :: amax, scond
! Array Arguments
real(${rk}$), intent(in) :: ab(ldab,*)
real(${rk}$), intent(out) :: s(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(${rk}$) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = ab( j, 1_${ik}$ )
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = ab( j, i )
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ri}$pbequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! CPBEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(out) :: amax, scond
! Array Arguments
real(sp), intent(out) :: s(*)
complex(sp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(sp) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ab( j, 1_${ik}$ ),KIND=sp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = real( ab( j, i ),KIND=sp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_cpbequ
pure module subroutine stdlib${ii}$_zpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! ZPBEQU computes row and column scalings intended to equilibrate a
!! Hermitian positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(out) :: amax, scond
! Array Arguments
real(dp), intent(out) :: s(*)
complex(dp), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(dp) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ab( j, 1_${ik}$ ),KIND=dp)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = real( ab( j, i ),KIND=dp)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_zpbequ
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pbequ( uplo, n, kd, ab, ldab, s, scond, amax, info )
!! ZPBEQU: computes row and column scalings intended to equilibrate a
!! Hermitian positive definite band matrix A and reduce its condition
!! number (with respect to the two-norm). S contains the scale factors,
!! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
!! choice of S puts the condition number of B within a factor N of the
!! smallest possible condition number over all possible diagonal
!! scalings.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kd, ldab, n
real(${ck}$), intent(out) :: amax, scond
! Array Arguments
real(${ck}$), intent(out) :: s(*)
complex(${ck}$), intent(in) :: ab(ldab,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j
real(${ck}$) :: smin
! 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( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( ldab<kd+1 ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPBEQU', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
scond = one
amax = zero
return
end if
if( upper ) then
j = kd + 1_${ik}$
else
j = 1_${ik}$
end if
! initialize smin and amax.
s( 1_${ik}$ ) = real( ab( j, 1_${ik}$ ),KIND=${ck}$)
smin = s( 1_${ik}$ )
amax = s( 1_${ik}$ )
! find the minimum and maximum diagonal elements.
do i = 2, n
s( i ) = real( ab( j, i ),KIND=${ck}$)
smin = min( smin, s( i ) )
amax = max( amax, s( i ) )
end do
if( smin<=zero ) then
! find the first non-positive diagonal element and return.
do i = 1, n
if( s( i )<=zero ) then
info = i
return
end if
end do
else
! set the scale factors to the reciprocals
! of the diagonal elements.
do i = 1, n
s( i ) = one / sqrt( s( i ) )
end do
! compute scond = min(s(i)) / max(s(i))
scond = sqrt( smin ) / sqrt( amax )
end if
return
end subroutine stdlib${ii}$_${ci}$pbequ
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed )
!! CLAQHB equilibrates an Hermitian band matrix A using the scaling
!! factors in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: kd, ldab, n
real(sp), intent(in) :: amax, scond
! Array Arguments
real(sp), intent(out) :: s(*)
complex(sp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored in band format.
do j = 1, n
cj = s( j )
do i = max( 1, j-kd ), j - 1
ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j )
end do
ab( kd+1, j ) = cj*cj*real( ab( kd+1, j ),KIND=sp)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=sp)
do i = j + 1, min( n, j+kd )
ab( 1_${ik}$+i-j, j ) = cj*s( i )*ab( 1_${ik}$+i-j, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_claqhb
pure module subroutine stdlib${ii}$_zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed )
!! ZLAQHB equilibrates a Hermitian band matrix A
!! using the scaling factors in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: kd, ldab, n
real(dp), intent(in) :: amax, scond
! Array Arguments
real(dp), intent(out) :: s(*)
complex(dp), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored in band format.
do j = 1, n
cj = s( j )
do i = max( 1, j-kd ), j - 1
ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j )
end do
ab( kd+1, j ) = cj*cj*real( ab( kd+1, j ),KIND=dp)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=dp)
do i = j + 1, min( n, j+kd )
ab( 1_${ik}$+i-j, j ) = cj*s( i )*ab( 1_${ik}$+i-j, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_zlaqhb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed )
!! ZLAQHB: equilibrates a Hermitian band matrix A
!! using the scaling factors in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: kd, ldab, n
real(${ck}$), intent(in) :: amax, scond
! Array Arguments
real(${ck}$), intent(out) :: s(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j
real(${ck}$) :: cj, large, small
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored in band format.
do j = 1, n
cj = s( j )
do i = max( 1, j-kd ), j - 1
ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j )
end do
ab( kd+1, j ) = cj*cj*real( ab( kd+1, j ),KIND=${ck}$)
end do
else
! lower triangle of a is stored.
do j = 1, n
cj = s( j )
ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=${ck}$)
do i = j + 1, min( n, j+kd )
ab( 1_${ik}$+i-j, j ) = cj*s( i )*ab( 1_${ik}$+i-j, j )
end do
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_${ci}$laqhb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sptcon( n, d, e, anorm, rcond, work, info )
!! SPTCON computes the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite tridiagonal matrix
!! using the factorization A = L*D*L**T or A = U**T*D*U computed by
!! SPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(in) :: d(*), e(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(sp) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / d( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / d( i ) + work( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
ainvnm = abs( work( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_sptcon
pure module subroutine stdlib${ii}$_dptcon( n, d, e, anorm, rcond, work, info )
!! DPTCON computes the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite tridiagonal matrix
!! using the factorization A = L*D*L**T or A = U**T*D*U computed by
!! DPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(in) :: d(*), e(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(dp) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / d( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / d( i ) + work( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
ainvnm = abs( work( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_dptcon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ptcon( n, d, e, anorm, rcond, work, info )
!! DPTCON: computes the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric positive definite tridiagonal matrix
!! using the factorization A = L*D*L**T or A = U**T*D*U computed by
!! DPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
real(${rk}$), intent(in) :: d(*), e(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(${rk}$) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / d( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / d( i ) + work( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
ainvnm = abs( work( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ri}$ptcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cptcon( n, d, e, anorm, rcond, rwork, info )
!! CPTCON computes the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite tridiagonal matrix
!! using the factorization A = L*D*L**H or A = U**H*D*U computed by
!! CPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
real(sp), intent(in) :: d(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(sp) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / d( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / d( i ) + rwork( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
ainvnm = abs( rwork( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_cptcon
pure module subroutine stdlib${ii}$_zptcon( n, d, e, anorm, rcond, rwork, info )
!! ZPTCON computes the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite tridiagonal matrix
!! using the factorization A = L*D*L**H or A = U**H*D*U computed by
!! ZPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
real(dp), intent(in) :: d(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(dp) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / d( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / d( i ) + rwork( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
ainvnm = abs( rwork( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zptcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ptcon( n, d, e, anorm, rcond, rwork, info )
!! ZPTCON: computes the reciprocal of the condition number (in the
!! 1-norm) of a complex Hermitian positive definite tridiagonal matrix
!! using the factorization A = L*D*L**H or A = U**H*D*U computed by
!! ZPTTRF.
!! Norm(inv(A)) is computed by a direct method, and the reciprocal of
!! the condition number is computed as
!! RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
real(${ck}$), intent(in) :: d(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix
real(${ck}$) :: ainvnm
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( anorm<zero ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm==zero ) then
return
end if
! check that d(1:n) is positive.
do i = 1, n
if( d( i )<=zero )return
end do
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( e( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / d( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / d( i ) + rwork( i+1 )*abs( e( i ) )
end do
! compute ainvnm = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
ainvnm = abs( rwork( ix ) )
! compute the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$ptcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spttrf( n, d, e, info )
!! SPTTRF computes the L*D*L**T factorization of a real symmetric
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**T*D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(sp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'SPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**t (or u**t*d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 30
end if
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
end do
loop_20: do i = i4 + 1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 30
end if
! solve for e(i) and d(i+1).
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
if( d( i+1 )<=zero ) then
info = i + 1_${ik}$
go to 30
end if
! solve for e(i+1) and d(i+2).
ei = e( i+1 )
e( i+1 ) = ei / d( i+1 )
d( i+2 ) = d( i+2 ) - e( i+1 )*ei
if( d( i+2 )<=zero ) then
info = i + 2_${ik}$
go to 30
end if
! solve for e(i+2) and d(i+3).
ei = e( i+2 )
e( i+2 ) = ei / d( i+2 )
d( i+3 ) = d( i+3 ) - e( i+2 )*ei
if( d( i+3 )<=zero ) then
info = i + 3_${ik}$
go to 30
end if
! solve for e(i+3) and d(i+4).
ei = e( i+3 )
e( i+3 ) = ei / d( i+3 )
d( i+4 ) = d( i+4 ) - e( i+3 )*ei
end do loop_20
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
30 continue
return
end subroutine stdlib${ii}$_spttrf
pure module subroutine stdlib${ii}$_dpttrf( n, d, e, info )
!! DPTTRF computes the L*D*L**T factorization of a real symmetric
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**T*D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(dp) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**t (or u**t*d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 30
end if
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
end do
loop_20: do i = i4 + 1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 30
end if
! solve for e(i) and d(i+1).
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
if( d( i+1 )<=zero ) then
info = i + 1_${ik}$
go to 30
end if
! solve for e(i+1) and d(i+2).
ei = e( i+1 )
e( i+1 ) = ei / d( i+1 )
d( i+2 ) = d( i+2 ) - e( i+1 )*ei
if( d( i+2 )<=zero ) then
info = i + 2_${ik}$
go to 30
end if
! solve for e(i+2) and d(i+3).
ei = e( i+2 )
e( i+2 ) = ei / d( i+2 )
d( i+3 ) = d( i+3 ) - e( i+2 )*ei
if( d( i+3 )<=zero ) then
info = i + 3_${ik}$
go to 30
end if
! solve for e(i+3) and d(i+4).
ei = e( i+3 )
e( i+3 ) = ei / d( i+3 )
d( i+4 ) = d( i+4 ) - e( i+3 )*ei
end do loop_20
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
30 continue
return
end subroutine stdlib${ii}$_dpttrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pttrf( n, d, e, info )
!! DPTTRF: computes the L*D*L**T factorization of a real symmetric
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**T*D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(${rk}$) :: ei
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**t (or u**t*d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 30
end if
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
end do
loop_20: do i = i4 + 1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 30
end if
! solve for e(i) and d(i+1).
ei = e( i )
e( i ) = ei / d( i )
d( i+1 ) = d( i+1 ) - e( i )*ei
if( d( i+1 )<=zero ) then
info = i + 1_${ik}$
go to 30
end if
! solve for e(i+1) and d(i+2).
ei = e( i+1 )
e( i+1 ) = ei / d( i+1 )
d( i+2 ) = d( i+2 ) - e( i+1 )*ei
if( d( i+2 )<=zero ) then
info = i + 2_${ik}$
go to 30
end if
! solve for e(i+2) and d(i+3).
ei = e( i+2 )
e( i+2 ) = ei / d( i+2 )
d( i+3 ) = d( i+3 ) - e( i+2 )*ei
if( d( i+3 )<=zero ) then
info = i + 3_${ik}$
go to 30
end if
! solve for e(i+3) and d(i+4).
ei = e( i+3 )
e( i+3 ) = ei / d( i+3 )
d( i+4 ) = d( i+4 ) - e( i+3 )*ei
end do loop_20
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
30 continue
return
end subroutine stdlib${ii}$_${ri}$pttrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpttrf( n, d, e, info )
!! CPTTRF computes the L*D*L**H factorization of a complex Hermitian
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**H *D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: d(*)
complex(sp), intent(inout) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(sp) :: eii, eir, f, g
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'CPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**h (or u**h *d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 20
end if
eir = real( e( i ),KIND=sp)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=sp)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
end do
loop_110: do i = i4+1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 20
end if
! solve for e(i) and d(i+1).
eir = real( e( i ),KIND=sp)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=sp)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
if( d( i+1 )<=zero ) then
info = i+1
go to 20
end if
! solve for e(i+1) and d(i+2).
eir = real( e( i+1 ),KIND=sp)
eii = aimag( e( i+1 ) )
f = eir / d( i+1 )
g = eii / d( i+1 )
e( i+1 ) = cmplx( f, g,KIND=sp)
d( i+2 ) = d( i+2 ) - f*eir - g*eii
if( d( i+2 )<=zero ) then
info = i+2
go to 20
end if
! solve for e(i+2) and d(i+3).
eir = real( e( i+2 ),KIND=sp)
eii = aimag( e( i+2 ) )
f = eir / d( i+2 )
g = eii / d( i+2 )
e( i+2 ) = cmplx( f, g,KIND=sp)
d( i+3 ) = d( i+3 ) - f*eir - g*eii
if( d( i+3 )<=zero ) then
info = i+3
go to 20
end if
! solve for e(i+3) and d(i+4).
eir = real( e( i+3 ),KIND=sp)
eii = aimag( e( i+3 ) )
f = eir / d( i+3 )
g = eii / d( i+3 )
e( i+3 ) = cmplx( f, g,KIND=sp)
d( i+4 ) = d( i+4 ) - f*eir - g*eii
end do loop_110
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
20 continue
return
end subroutine stdlib${ii}$_cpttrf
pure module subroutine stdlib${ii}$_zpttrf( n, d, e, info )
!! ZPTTRF computes the L*D*L**H factorization of a complex Hermitian
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**H *D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: d(*)
complex(dp), intent(inout) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(dp) :: eii, eir, f, g
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'ZPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**h (or u**h *d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 30
end if
eir = real( e( i ),KIND=dp)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=dp)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
end do
loop_20: do i = i4 + 1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 30
end if
! solve for e(i) and d(i+1).
eir = real( e( i ),KIND=dp)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=dp)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
if( d( i+1 )<=zero ) then
info = i + 1_${ik}$
go to 30
end if
! solve for e(i+1) and d(i+2).
eir = real( e( i+1 ),KIND=dp)
eii = aimag( e( i+1 ) )
f = eir / d( i+1 )
g = eii / d( i+1 )
e( i+1 ) = cmplx( f, g,KIND=dp)
d( i+2 ) = d( i+2 ) - f*eir - g*eii
if( d( i+2 )<=zero ) then
info = i + 2_${ik}$
go to 30
end if
! solve for e(i+2) and d(i+3).
eir = real( e( i+2 ),KIND=dp)
eii = aimag( e( i+2 ) )
f = eir / d( i+2 )
g = eii / d( i+2 )
e( i+2 ) = cmplx( f, g,KIND=dp)
d( i+3 ) = d( i+3 ) - f*eir - g*eii
if( d( i+3 )<=zero ) then
info = i + 3_${ik}$
go to 30
end if
! solve for e(i+3) and d(i+4).
eir = real( e( i+3 ),KIND=dp)
eii = aimag( e( i+3 ) )
f = eir / d( i+3 )
g = eii / d( i+3 )
e( i+3 ) = cmplx( f, g,KIND=dp)
d( i+4 ) = d( i+4 ) - f*eir - g*eii
end do loop_20
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
30 continue
return
end subroutine stdlib${ii}$_zpttrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pttrf( n, d, e, info )
!! ZPTTRF: computes the L*D*L**H factorization of a complex Hermitian
!! positive definite tridiagonal matrix A. The factorization may also
!! be regarded as having the form A = U**H *D*U.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${ck}$), intent(inout) :: d(*)
complex(${ck}$), intent(inout) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, i4
real(${ck}$) :: eii, eir, f, g
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'ZPTTRF', -info )
return
end if
! quick return if possible
if( n==0 )return
! compute the l*d*l**h (or u**h *d*u) factorization of a.
i4 = mod( n-1, 4_${ik}$ )
do i = 1, i4
if( d( i )<=zero ) then
info = i
go to 30
end if
eir = real( e( i ),KIND=${ck}$)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=${ck}$)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
end do
loop_20: do i = i4 + 1, n - 4, 4
! drop out of the loop if d(i) <= 0: the matrix is not positive
! definite.
if( d( i )<=zero ) then
info = i
go to 30
end if
! solve for e(i) and d(i+1).
eir = real( e( i ),KIND=${ck}$)
eii = aimag( e( i ) )
f = eir / d( i )
g = eii / d( i )
e( i ) = cmplx( f, g,KIND=${ck}$)
d( i+1 ) = d( i+1 ) - f*eir - g*eii
if( d( i+1 )<=zero ) then
info = i + 1_${ik}$
go to 30
end if
! solve for e(i+1) and d(i+2).
eir = real( e( i+1 ),KIND=${ck}$)
eii = aimag( e( i+1 ) )
f = eir / d( i+1 )
g = eii / d( i+1 )
e( i+1 ) = cmplx( f, g,KIND=${ck}$)
d( i+2 ) = d( i+2 ) - f*eir - g*eii
if( d( i+2 )<=zero ) then
info = i + 2_${ik}$
go to 30
end if
! solve for e(i+2) and d(i+3).
eir = real( e( i+2 ),KIND=${ck}$)
eii = aimag( e( i+2 ) )
f = eir / d( i+2 )
g = eii / d( i+2 )
e( i+2 ) = cmplx( f, g,KIND=${ck}$)
d( i+3 ) = d( i+3 ) - f*eir - g*eii
if( d( i+3 )<=zero ) then
info = i + 3_${ik}$
go to 30
end if
! solve for e(i+3) and d(i+4).
eir = real( e( i+3 ),KIND=${ck}$)
eii = aimag( e( i+3 ) )
f = eir / d( i+3 )
g = eii / d( i+3 )
e( i+3 ) = cmplx( f, g,KIND=${ck}$)
d( i+4 ) = d( i+4 ) - f*eir - g*eii
end do loop_20
! check d(n) for positive definiteness.
if( d( n )<=zero )info = n
30 continue
return
end subroutine stdlib${ii}$_${ci}$pttrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spttrs( n, nrhs, d, e, b, ldb, info )
!! SPTTRS solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by SPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(sp), intent(inout) :: b(ldb,*)
real(sp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'SPTTRS', ' ', n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_sptts2( n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_sptts2( n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_spttrs
pure module subroutine stdlib${ii}$_dpttrs( n, nrhs, d, e, b, ldb, info )
!! DPTTRS solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by DPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(dp), intent(inout) :: b(ldb,*)
real(dp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DPTTRS', ' ', n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_dptts2( n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_dptts2( n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_dpttrs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pttrs( n, nrhs, d, e, b, ldb, info )
!! DPTTRS: solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by DPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(inout) :: b(ldb,*)
real(${rk}$), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DPTTRS', ' ', n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
if( nb>=nrhs ) then
call stdlib${ii}$_${ri}$ptts2( n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_${ri}$ptts2( n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_${ri}$pttrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpttrs( uplo, n, nrhs, d, e, b, ldb, info )
!! CPTTRS solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: d(*)
complex(sp), intent(inout) :: b(ldb,*)
complex(sp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: iuplo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
upper = ( uplo=='U' .or. uplo=='U' )
if( .not.upper .and. .not.( uplo=='L' .or. uplo=='L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'CPTTRS', uplo, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
! decode uplo
if( upper ) then
iuplo = 1_${ik}$
else
iuplo = 0_${ik}$
end if
if( nb>=nrhs ) then
call stdlib${ii}$_cptts2( iuplo, n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_cptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_cpttrs
pure module subroutine stdlib${ii}$_zpttrs( uplo, n, nrhs, d, e, b, ldb, info )
!! ZPTTRS solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H *D* U or A = L*D*L**H computed by ZPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: d(*)
complex(dp), intent(inout) :: b(ldb,*)
complex(dp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: iuplo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
upper = ( uplo=='U' .or. uplo=='U' )
if( .not.upper .and. .not.( uplo=='L' .or. uplo=='L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPTTRS', uplo, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
! decode uplo
if( upper ) then
iuplo = 1_${ik}$
else
iuplo = 0_${ik}$
end if
if( nb>=nrhs ) then
call stdlib${ii}$_zptts2( iuplo, n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_zptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_zpttrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pttrs( uplo, n, nrhs, d, e, b, ldb, info )
!! ZPTTRS: solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H *D* U or A = L*D*L**H computed by ZPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- 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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(${ck}$), intent(in) :: d(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
complex(${ck}$), intent(in) :: e(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: iuplo, j, jb, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments.
info = 0_${ik}$
upper = ( uplo=='U' .or. uplo=='U' )
if( .not.upper .and. .not.( uplo=='L' .or. uplo=='L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! determine the number of right-hand sides to solve at a time.
if( nrhs==1_${ik}$ ) then
nb = 1_${ik}$
else
nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPTTRS', uplo, n, nrhs, -1_${ik}$, -1_${ik}$ ) )
end if
! decode uplo
if( upper ) then
iuplo = 1_${ik}$
else
iuplo = 0_${ik}$
end if
if( nb>=nrhs ) then
call stdlib${ii}$_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb )
else
do j = 1, nrhs, nb
jb = min( nrhs-j+1, nb )
call stdlib${ii}$_${ci}$ptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb )
end do
end if
return
end subroutine stdlib${ii}$_${ci}$pttrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sptts2( n, nrhs, d, e, b, ldb )
!! SPTTS2 solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by SPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(sp), intent(inout) :: b(ldb,*)
real(sp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_sscal( nrhs, 1. / d( 1_${ik}$ ), b, ldb )
return
end if
! solve a * x = b using the factorization a = l*d*l**t,
! overwriting each right hand side vector with its solution.
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**t * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
return
end subroutine stdlib${ii}$_sptts2
pure module subroutine stdlib${ii}$_dptts2( n, nrhs, d, e, b, ldb )
!! DPTTS2 solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by DPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(dp), intent(inout) :: b(ldb,*)
real(dp), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_dscal( nrhs, 1._dp / d( 1_${ik}$ ), b, ldb )
return
end if
! solve a * x = b using the factorization a = l*d*l**t,
! overwriting each right hand side vector with its solution.
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**t * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
return
end subroutine stdlib${ii}$_dptts2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ptts2( n, nrhs, d, e, b, ldb )
!! DPTTS2: solves a tridiagonal system of the form
!! A * X = B
!! using the L*D*L**T factorization of A computed by DPTTRF. D is a
!! diagonal matrix specified in the vector D, L is a unit bidiagonal
!! matrix whose subdiagonal is specified in the vector E, and X and B
!! are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ldb, n, nrhs
! Array Arguments
real(${rk}$), intent(inout) :: b(ldb,*)
real(${rk}$), intent(in) :: d(*), e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_${ri}$scal( nrhs, 1._${rk}$ / d( 1_${ik}$ ), b, ldb )
return
end if
! solve a * x = b using the factorization a = l*d*l**t,
! overwriting each right hand side vector with its solution.
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**t * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
return
end subroutine stdlib${ii}$_${ri}$ptts2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cptts2( iuplo, n, nrhs, d, e, b, ldb )
!! CPTTS2 solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: iuplo, ldb, n, nrhs
! Array Arguments
real(sp), intent(in) :: d(*)
complex(sp), intent(inout) :: b(ldb,*)
complex(sp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_csscal( nrhs, 1. / d( 1_${ik}$ ), b, ldb )
return
end if
if( iuplo==1_${ik}$ ) then
! solve a * x = b using the factorization a = u**h *d*u,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
5 continue
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*e( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 5
end if
else
do j = 1, nrhs
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
end if
else
! solve a * x = b using the factorization a = l*d*l**h,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
65 continue
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*conjg( e( i ) )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 65
end if
else
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) -b( i+1, j )*conjg( e( i ) )
end do
end do
end if
end if
return
end subroutine stdlib${ii}$_cptts2
pure module subroutine stdlib${ii}$_zptts2( iuplo, n, nrhs, d, e, b, ldb )
!! ZPTTS2 solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H *D*U or A = L*D*L**H computed by ZPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: iuplo, ldb, n, nrhs
! Array Arguments
real(dp), intent(in) :: d(*)
complex(dp), intent(inout) :: b(ldb,*)
complex(dp), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_zdscal( nrhs, 1._dp / d( 1_${ik}$ ), b, ldb )
return
end if
if( iuplo==1_${ik}$ ) then
! solve a * x = b using the factorization a = u**h *d*u,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*e( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
end if
else
! solve a * x = b using the factorization a = l*d*l**h,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
80 continue
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*conjg( e( i ) )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 80
end if
else
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) -b( i+1, j )*conjg( e( i ) )
end do
end do
end if
end if
return
end subroutine stdlib${ii}$_zptts2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb )
!! ZPTTS2: solves a tridiagonal system of the form
!! A * X = B
!! using the factorization A = U**H *D*U or A = L*D*L**H computed by ZPTTRF.
!! D is a diagonal matrix specified in the vector D, U (or L) is a unit
!! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
!! the vector E, and X and B are N by NRHS matrices.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: iuplo, ldb, n, nrhs
! Array Arguments
real(${ck}$), intent(in) :: d(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
complex(${ck}$), intent(in) :: e(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( n<=1_${ik}$ ) then
if( n==1_${ik}$ )call stdlib${ii}$_${ci}$dscal( nrhs, 1._${ck}$ / d( 1_${ik}$ ), b, ldb )
return
end if
if( iuplo==1_${ik}$ ) then
! solve a * x = b using the factorization a = u**h *d*u,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
10 continue
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*e( i )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 10
end if
else
do j = 1, nrhs
! solve u**h * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*conjg( e( i-1 ) )
end do
! solve d * u * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i )
end do
end do
end if
else
! solve a * x = b using the factorization a = l*d*l**h,
! overwriting each right hand side vector with its solution.
if( nrhs<=2_${ik}$ ) then
j = 1_${ik}$
80 continue
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
do i = 1, n
b( i, j ) = b( i, j ) / d( i )
end do
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) - b( i+1, j )*conjg( e( i ) )
end do
if( j<nrhs ) then
j = j + 1_${ik}$
go to 80
end if
else
do j = 1, nrhs
! solve l * x = b.
do i = 2, n
b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 )
end do
! solve d * l**h * x = b.
b( n, j ) = b( n, j ) / d( n )
do i = n - 1, 1, -1
b( i, j ) = b( i, j ) / d( i ) -b( i+1, j )*conjg( e( i ) )
end do
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$ptts2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info )
!! SPTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*)
real(sp), intent(out) :: berr(*), ferr(*), work(*)
real(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
integer(${ik}$) :: count, i, ix, j, nz
real(sp) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${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( 'SPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_90: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( n+1 ) = bi - dx
work( 1_${ik}$ ) = abs( bi ) + abs( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( n+1 ) = bi - dx - ex
work( 1_${ik}$ ) = abs( bi ) + abs( dx ) + abs( ex )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( n+i ) = bi - cx - dx - ex
work( i ) = abs( bi ) + abs( cx ) + abs( dx ) + abs( ex )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n+n ) = bi - cx - dx
work( n ) = abs( bi ) + abs( cx ) + abs( dx )
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_spttrs( n, 1_${ik}$, df, ef, work( n+1 ), n, info )
call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
ferr( j ) = work( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / df( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( work( ix ) )
! 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_90
return
end subroutine stdlib${ii}$_sptrfs
pure module subroutine stdlib${ii}$_dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info )
!! DPTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*)
real(dp), intent(out) :: berr(*), ferr(*), work(*)
real(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
integer(${ik}$) :: count, i, ix, j, nz
real(dp) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${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( 'DPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_90: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( n+1 ) = bi - dx
work( 1_${ik}$ ) = abs( bi ) + abs( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( n+1 ) = bi - dx - ex
work( 1_${ik}$ ) = abs( bi ) + abs( dx ) + abs( ex )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( n+i ) = bi - cx - dx - ex
work( i ) = abs( bi ) + abs( cx ) + abs( dx ) + abs( ex )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n+n ) = bi - cx - dx
work( n ) = abs( bi ) + abs( cx ) + abs( dx )
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_dpttrs( n, 1_${ik}$, df, ef, work( n+1 ), n, info )
call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
ferr( j ) = work( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / df( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( work( ix ) )
! 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_90
return
end subroutine stdlib${ii}$_dptrfs
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info )
!! DPTRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is symmetric positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(${rk}$), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*)
real(${rk}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
integer(${ik}$) :: count, i, ix, j, nz
real(${rk}$) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -2_${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( 'DPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_90: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( n+1 ) = bi - dx
work( 1_${ik}$ ) = abs( bi ) + abs( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( n+1 ) = bi - dx - ex
work( 1_${ik}$ ) = abs( bi ) + abs( dx ) + abs( ex )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( n+i ) = bi - cx - dx - ex
work( i ) = abs( bi ) + abs( cx ) + abs( dx ) + abs( ex )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n+n ) = bi - cx - dx
work( n ) = abs( bi ) + abs( cx ) + abs( dx )
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( work( i )>safe2 ) then
s = max( s, abs( work( n+i ) ) / work( i ) )
else
s = max( s, ( abs( work( n+i ) )+safe1 ) /( work( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ri}$pttrs( n, 1_${ik}$, df, ef, work( n+1 ), n, info )
call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
ferr( j ) = work( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t.
! solve m(l) * x = e.
work( 1_${ik}$ ) = one
do i = 2, n
work( i ) = one + work( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**t * x = b.
work( n ) = work( n ) / df( n )
do i = n - 1, 1, -1
work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( work( ix ) )
! 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_90
return
end subroutine stdlib${ii}$_${ri}$ptrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, &
!! CPTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
real(sp), intent(in) :: d(*), df(*)
complex(sp), intent(in) :: b(ldb,*), e(*), ef(*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ix, j, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin
complex(sp) :: bi, cx, dx, ex, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${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( 'CPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_100: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( upper ) then
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = conjg( e( i-1 ) )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = conjg( e( n-1 ) )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
else
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = conjg( e( 1_${ik}$ ) )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = conjg( e( i ) )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_cpttrs( uplo, n, 1_${ik}$, df, ef, work, n, info )
call stdlib${ii}$_caxpy( n, cmplx( one,KIND=sp), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
ferr( j ) = rwork( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / df( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( rwork( ix ) )
! 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_100
return
end subroutine stdlib${ii}$_cptrfs
pure module subroutine stdlib${ii}$_zptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, &
!! ZPTRFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
real(dp), intent(in) :: d(*), df(*)
complex(dp), intent(in) :: b(ldb,*), e(*), ef(*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ix, j, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin
complex(dp) :: bi, cx, dx, ex, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${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( 'ZPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_100: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( upper ) then
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = conjg( e( i-1 ) )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = conjg( e( n-1 ) )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
else
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = conjg( e( 1_${ik}$ ) )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = conjg( e( i ) )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zpttrs( uplo, n, 1_${ik}$, df, ef, work, n, info )
call stdlib${ii}$_zaxpy( n, cmplx( one,KIND=dp), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
ferr( j ) = rwork( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / df( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( rwork( ix ) )
! 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_100
return
end subroutine stdlib${ii}$_zptrfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, &
!! ZPTRFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian positive definite
!! and tridiagonal, and provides error bounds and backward error
!! estimates for the solution.
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) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
! Array Arguments
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
real(${ck}$), intent(in) :: d(*), df(*)
complex(${ck}$), intent(in) :: b(ldb,*), e(*), ef(*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, ix, j, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin
complex(${ck}$) :: bi, cx, dx, ex, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
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( nrhs<0_${ik}$ ) then
info = -3_${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( 'ZPTRFS', -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
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = 4_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_100: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x. also compute
! abs(a)*abs(x) + abs(b) for use in the backward error bound.
if( upper ) then
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = e( 1_${ik}$ )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = conjg( e( i-1 ) )*x( i-1, j )
dx = d( i )*x( i, j )
ex = e( i )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = conjg( e( n-1 ) )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
else
if( n==1_${ik}$ ) then
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
work( 1_${ik}$ ) = bi - dx
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx )
else
bi = b( 1_${ik}$, j )
dx = d( 1_${ik}$ )*x( 1_${ik}$, j )
ex = conjg( e( 1_${ik}$ ) )*x( 2_${ik}$, j )
work( 1_${ik}$ ) = bi - dx - ex
rwork( 1_${ik}$ ) = cabs1( bi ) + cabs1( dx ) +cabs1( e( 1_${ik}$ ) )*cabs1( x( 2_${ik}$, j ) )
do i = 2, n - 1
bi = b( i, j )
cx = e( i-1 )*x( i-1, j )
dx = d( i )*x( i, j )
ex = conjg( e( i ) )*x( i+1, j )
work( i ) = bi - cx - dx - ex
rwork( i ) = cabs1( bi ) +cabs1( e( i-1 ) )*cabs1( x( i-1, j ) ) +cabs1( &
dx ) + cabs1( e( i ) )*cabs1( x( i+1, j ) )
end do
bi = b( n, j )
cx = e( n-1 )*x( n-1, j )
dx = d( n )*x( n, j )
work( n ) = bi - cx - dx
rwork( n ) = cabs1( bi ) + cabs1( e( n-1 ) )*cabs1( x( n-1, j ) ) + cabs1( dx &
)
end if
end if
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$pttrs( uplo, n, 1_${ik}$, df, ef, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of 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(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
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
ix = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
ferr( j ) = rwork( ix )
! estimate the norm of inv(a).
! solve m(a) * x = e, where m(a) = (m(i,j)) is given by
! m(i,j) = abs(a(i,j)), i = j,
! m(i,j) = -abs(a(i,j)), i .ne. j,
! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h.
! solve m(l) * x = e.
rwork( 1_${ik}$ ) = one
do i = 2, n
rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) )
end do
! solve d * m(l)**h * x = b.
rwork( n ) = rwork( n ) / df( n )
do i = n - 1, 1, -1
rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) )
end do
! compute norm(inv(a)) = max(x(i)), 1<=i<=n.
ix = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
ferr( j ) = ferr( j )*abs( rwork( ix ) )
! 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_100
return
end subroutine stdlib${ii}$_${ci}$ptrfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaqsp( uplo, n, ap, s, scond, amax, equed )
!! SLAQSP equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: amax, scond
! Array Arguments
real(sp), intent(inout) :: ap(*)
real(sp), intent(in) :: s(*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(sp) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_slaqsp
pure module subroutine stdlib${ii}$_dlaqsp( uplo, n, ap, s, scond, amax, equed )
!! DLAQSP equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: amax, scond
! Array Arguments
real(dp), intent(inout) :: ap(*)
real(dp), intent(in) :: s(*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(dp) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_dlaqsp
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laqsp( uplo, n, ap, s, scond, amax, equed )
!! DLAQSP: equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(${rk}$), intent(in) :: amax, scond
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(in) :: s(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$
! Local Scalars
integer(${ik}$) :: i, j, jc
real(${rk}$) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_${ri}$laqsp
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claqsp( uplo, n, ap, s, scond, amax, equed )
!! CLAQSP equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: amax, scond
! Array Arguments
real(sp), intent(in) :: s(*)
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(sp), parameter :: thresh = 0.1e+0_sp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(sp) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_claqsp
pure module subroutine stdlib${ii}$_zlaqsp( uplo, n, ap, s, scond, amax, equed )
!! ZLAQSP equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: amax, scond
! Array Arguments
real(dp), intent(in) :: s(*)
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(dp), parameter :: thresh = 0.1e+0_dp
! Local Scalars
integer(${ik}$) :: i, j, jc
real(dp) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_zlaqsp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laqsp( uplo, n, ap, s, scond, amax, equed )
!! ZLAQSP: equilibrates a symmetric matrix A using the scaling factors
!! in the vector S.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(out) :: equed
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: amax, scond
! Array Arguments
real(${ck}$), intent(in) :: s(*)
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$
! Local Scalars
integer(${ik}$) :: i, j, jc
real(${ck}$) :: cj, large, small
! Executable Statements
! quick return if possible
if( n<=0_${ik}$ ) then
equed = 'N'
return
end if
! initialize large and small.
small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
large = one / small
if( scond>=thresh .and. amax>=small .and. amax<=large ) then
! no equilibration
equed = 'N'
else
! replace a by diag(s) * a * diag(s).
if( stdlib_lsame( uplo, 'U' ) ) then
! upper triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = 1, j
ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
end do
jc = jc + j
end do
else
! lower triangle of a is stored.
jc = 1_${ik}$
do j = 1, n
cj = s( j )
do i = j, n
ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
end do
jc = jc + n - j + 1_${ik}$
end do
end if
equed = 'Y'
end if
return
end subroutine stdlib${ii}$_${ci}$laqsp
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_chol_comp
