#: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 = 