#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_ldl
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! SSYSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_ssytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_ssytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_ssytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_ssytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssysv
pure module subroutine stdlib${ii}$_dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_dsytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_dsytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_dsytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_dsytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsysv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV: computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ri}$sytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ri}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_${ri}$sytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_${ri}$sytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sysv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CSYSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_csytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=sp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_csytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_csytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_csytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csysv
pure module subroutine stdlib${ii}$_zsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_zsytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=dp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_zsytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_zsytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_zsytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsysv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ci}$sytrf( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=${ck}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_${ci}$sytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_${ci}$sytrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sysv
#:endif
#:endfor
module subroutine stdlib${ii}$_ssysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! SSYSVX uses the diagonal pivoting factorization to compute the
!! solution to a real system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*), b(ldb,*)
real(sp), intent(inout) :: af(ldaf,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 3_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_slacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_ssytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_slansy( 'I', uplo, n, a, lda, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_ssycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info )
! compute the solution vectors x.
call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_ssytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssysvx
module subroutine stdlib${ii}$_dsysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! DSYSVX uses the diagonal pivoting factorization to compute the
!! solution to a real system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*), b(ldb,*)
real(dp), intent(inout) :: af(ldaf,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 3_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_dlacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_dsytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_dlansy( 'I', uplo, n, a, lda, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_dsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info )
! compute the solution vectors x.
call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_dsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_dsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsysvx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! DSYSVX: uses the diagonal pivoting factorization to compute the
!! solution to a real system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(inout) :: af(ldaf,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(${rk}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 3_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ri}$lacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_${ri}$sytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ri}$lansy( 'I', uplo, n, a, lda, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ri}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info )
! compute the solution vectors x.
call stdlib${ii}$_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ri}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ri}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${ri}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sysvx
#:endif
#:endfor
module subroutine stdlib${ii}$_csysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! CSYSVX uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), b(ldb,*)
complex(sp), intent(inout) :: af(ldaf,*)
complex(sp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_clacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_csytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_clansy( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_csycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_csytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_csyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csysvx
module subroutine stdlib${ii}$_zsysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! ZSYSVX uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), b(ldb,*)
complex(dp), intent(inout) :: af(ldaf,*)
complex(dp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_zlacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_zsytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_zlansy( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_zsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_zsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_zsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsysvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$sysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! ZSYSVX: uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(inout) :: af(ldaf,*)
complex(${ck}$), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(${ck}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ci}$lacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_${ci}$sytrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ci}$lansy( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ci}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ci}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ci}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sysvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info )
!! SSYSV_RK computes the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! SSYTRF_RK is called to compute the factorization of a real
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine SSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**t)*(p**t) or
! a = p*u*d*(u**t)*(p**t).
call stdlib${ii}$_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_ssytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssysv_rk
pure module subroutine stdlib${ii}$_dsysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info )
!! DSYSV_RK computes the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! DSYTRF_RK is called to compute the factorization of a real
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine DSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**t)*(p**t) or
! a = p*u*d*(u**t)*(p**t).
call stdlib${ii}$_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_dsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsysv_rk
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info )
!! DSYSV_RK: computes the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! DSYTRF_RK is called to compute the factorization of a real
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine DSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ri}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**t)*(p**t) or
! a = p*u*d*(u**t)*(p**t).
call stdlib${ii}$_${ri}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_${ri}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sysv_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! CSYSV_RK computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! CSYTRF_RK is called to compute the factorization of a complex
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine CSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_csytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=sp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_csytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_csytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csysv_rk
pure module subroutine stdlib${ii}$_zsysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! ZSYSV_RK computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! ZSYTRF_RK is called to compute the factorization of a complex
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine ZSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_zsytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=dp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**t)*(p**t) or
! a = p*u*d*(u**t)*(p**t).
call stdlib${ii}$_zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_zsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsysv_rk
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! ZSYSV_RK: computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**T (or L**T) is the transpose of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is symmetric and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! ZSYTRF_RK is called to compute the factorization of a complex
!! symmetric matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine ZSYTRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=${ck}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**t)*(p**t) or
! a = p*u*d*(u**t)*(p**t).
call stdlib${ii}$_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_${ci}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sysv_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! SSYSV_ROOK computes the solution to a real system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! SSYTRF_ROOK is called to compute the factorization of a real
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling SSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_ssytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssysv_rook
pure module subroutine stdlib${ii}$_dsysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV_ROOK computes the solution to a real system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! DSYTRF_ROOK is called to compute the factorization of a real
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling DSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_dsytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsysv_rook
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV_ROOK: computes the solution to a real system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! DSYTRF_ROOK is called to compute the factorization of a real
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling DSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ri}$sytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = work(1_${ik}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ri}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_${ri}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sysv_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CSYSV_ROOK computes the solution to a complex system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! CSYTRF_ROOK is called to compute the factorization of a complex
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling CSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_csytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=sp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csysv_rook
pure module subroutine stdlib${ii}$_zsysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV_ROOK computes the solution to a complex system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! ZSYTRF_ROOK is called to compute the factorization of a complex
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling ZSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_zsytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=dp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsysv_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV_ROOK: computes the solution to a complex system of linear
!! equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! ZSYTRF_ROOK is called to compute the factorization of a complex
!! symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling ZSYTRS_ROOK.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=${ck}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs_rook ( use level 2 blas)
call stdlib${ii}$_${ci}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sysv_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CHESV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHESV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_chetrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_chetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_chetrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chesv
pure module subroutine stdlib${ii}$_zhesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_zhetrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_zhetrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhesv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
!! used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_${ci}$hetrf( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
if ( lwork<n ) then
! solve with trs ( use level blas 2)
call stdlib${ii}$_${ci}$hetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
else
! solve with trs2 ( use level blas 3)
call stdlib${ii}$_${ci}$hetrs2( uplo,n,nrhs,a,lda,ipiv,b,ldb,work,info )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hesv
#:endif
#:endfor
module subroutine stdlib${ii}$_chesvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! CHESVX uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), b(ldb,*)
complex(sp), intent(inout) :: af(ldaf,*)
complex(sp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHESVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_clacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_chetrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_clanhe( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_checon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_chetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chesvx
module subroutine stdlib${ii}$_zhesvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! ZHESVX uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), b(ldb,*)
complex(dp), intent(inout) :: af(ldaf,*)
complex(dp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_zlacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_zhetrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_zlanhe( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_zhecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_zhetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhesvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hesvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b,ldb, x, ldx, rcond, &
!! ZHESVX: uses the diagonal pivoting factorization to compute the
!! solution to a complex system of linear equations A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
ferr, berr, work, lwork,rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, lwork, n, nrhs
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(inout) :: af(ldaf,*)
complex(${ck}$), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, nofact
integer(${ik}$) :: lwkopt, nb
real(${ck}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
lquery = ( lwork==-1_${ik}$ )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
if( info==0_${ik}$ ) then
lwkopt = max( 1_${ik}$, 2_${ik}$*n )
if( nofact ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkopt, n*nb )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESVX', -info )
return
else if( lquery ) then
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_${ci}$lacpy( uplo, n, n, a, lda, af, ldaf )
call stdlib${ii}$_${ci}$hetrf( uplo, n, af, ldaf, ipiv, work, lwork, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ci}$lanhe( 'I', uplo, n, a, lda, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ci}$hecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ci}$hetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, &
work, rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hesvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! CHESV_RK computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**H)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**H (or L**H) is the conjugate of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is Hermitian and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! CHETRF_RK is called to compute the factorization of a complex
!! Hermitian matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine CHETRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_chetrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=sp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHESV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_chetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_chetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chesv_rk
pure module subroutine stdlib${ii}$_zhesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! ZHESV_RK computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**H)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**H (or L**H) is the conjugate of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is Hermitian and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! ZHETRF_RK is called to compute the factorization of a complex
!! Hermitian matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine ZHETRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_zhetrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=dp)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**h)*(p**t) or
! a = p*u*d*(u**h)*(p**t).
call stdlib${ii}$_zhetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_zhetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhesv_rk
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info )
!! ZHESV_RK: computes the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix
!! and X and B are N-by-NRHS matrices.
!! The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!! to factor A as
!! A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or
!! A = P*L*D*(L**H)*(P**T), if UPLO = 'L',
!! where U (or L) is unit upper (or lower) triangular matrix,
!! U**H (or L**H) is the conjugate of U (or L), P is a permutation
!! matrix, P**T is the transpose of P, and D is Hermitian and block
!! diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! ZHETRF_RK is called to compute the factorization of a complex
!! Hermitian matrix. The factored form of A is then used to solve
!! the system of equations A * X = B by calling BLAS3 routine ZHETRS_3.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: e(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( 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 = -9_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -11_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
call stdlib${ii}$_${ci}$hetrf_rk( uplo, n, a, lda, e, ipiv, work, -1_${ik}$, info )
lwkopt = real( work(1_${ik}$),KIND=${ck}$)
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_RK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = p*u*d*(u**h)*(p**t) or
! a = p*u*d*(u**h)*(p**t).
call stdlib${ii}$_${ci}$hetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b with blas3 solver, overwriting b with x.
call stdlib${ii}$_${ci}$hetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hesv_rk
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CHESV_ROOK computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
!! to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! CHETRF_ROOK is called to compute the factorization of a complex
!! Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling CHETRS_ROOK (uses BLAS 2).
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHESV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_chetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs ( use level blas 2)
call stdlib${ii}$_chetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chesv_rook
pure module subroutine stdlib${ii}$_zhesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV_ROOK computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
!! to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! ZHETRF_ROOK is called to compute the factorization of a complex
!! Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling ZHETRS_ROOK (uses BLAS 2).
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_zhetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs ( use level blas 2)
call stdlib${ii}$_zhetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhesv_rook
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV_ROOK: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used
!! to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is Hermitian and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! ZHETRF_ROOK is called to compute the factorization of a complex
!! Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal
!! pivoting method.
!! The factored form of A is then used to solve the system
!! of equations A * X = B by calling ZHETRS_ROOK (uses BLAS 2).
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
lwkopt = 1_${ik}$
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF_ROOK', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_ROOK ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_${ci}$hetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
! solve with trs ( use level blas 2)
call stdlib${ii}$_${ci}$hetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hesv_rook
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! SSPSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_ssptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_sspsv
pure module subroutine stdlib${ii}$_dspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! DSPSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_dsptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_dsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_dspsv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! DSPSV: computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ri}$sptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_${ri}$spsv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! CSPSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_csptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_csptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_cspsv
pure module subroutine stdlib${ii}$_zspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZSPSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_zsptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_zsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_zspsv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZSPSV: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**T, if UPLO = 'U', or
!! A = L * D * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is symmetric and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPSV ', -info )
return
end if
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ci}$sptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_${ci}$spsv
#:endif
#:endfor
module subroutine stdlib${ii}$_sspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: afp(*)
real(sp), intent(in) :: ap(*), b(ldb,*)
real(sp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_scopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_ssptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_slansp( 'I', uplo, n, ap, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_sspcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info )
! compute the solution vectors x.
call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_ssptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_sspsvx
module subroutine stdlib${ii}$_dspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: afp(*)
real(dp), intent(in) :: ap(*), b(ldb,*)
real(dp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_dcopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_dsptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_dlansp( 'I', uplo, n, ap, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_dspcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info )
! compute the solution vectors x.
call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_dsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_dsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_dspsvx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! DSPSVX: uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a real system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, iwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: afp(*)
real(${rk}$), intent(in) :: ap(*), b(ldb,*)
real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(${rk}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ri}$copy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_${ri}$sptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ri}$lansp( 'I', uplo, n, ap, work )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ri}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info )
! compute the solution vectors x.
call stdlib${ii}$_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ri}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ri}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
iwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${ri}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_${ri}$spsvx
#:endif
#:endfor
module subroutine stdlib${ii}$_cspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(inout) :: afp(*)
complex(sp), intent(in) :: ap(*), b(ldb,*)
complex(sp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_ccopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_csptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_clansp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_cspcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_csptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_cspsvx
module subroutine stdlib${ii}$_zspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(inout) :: afp(*)
complex(dp), intent(in) :: ap(*), b(ldb,*)
complex(dp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_zcopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_zsptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_zlansp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_zspcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_zsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_zspsvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$spsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! ZSPSVX: uses the diagonal pivoting factorization A = U*D*U**T or
!! A = L*D*L**T to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N symmetric matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(inout) :: afp(*)
complex(${ck}$), intent(in) :: ap(*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(${ck}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**t or a = l*d*l**t.
call stdlib${ii}$_${ci}$copy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_${ci}$sptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ci}$lansp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ci}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ci}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_${ci}$spsvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! CHPSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is Hermitian and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPSV ', -info )
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_chptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_chptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_chpsv
pure module subroutine stdlib${ii}$_zhpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZHPSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is Hermitian and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPSV ', -info )
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_zhptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_zhptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_zhpsv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZHPSV: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix stored in packed format and X
!! and B are N-by-NRHS matrices.
!! The diagonal pivoting method is used to factor A as
!! A = U * D * U**H, if UPLO = 'U', or
!! A = L * D * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, D is Hermitian and block diagonal with 1-by-1
!! and 2-by-2 diagonal blocks. The factored form of A is then used to
!! solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: ap(*), b(ldb,*)
! =====================================================================
! 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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPSV ', -info )
return
end if
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_${ci}$hptrf( uplo, n, ap, ipiv, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$hptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
end if
return
end subroutine stdlib${ii}$_${ci}$hpsv
#:endif
#:endfor
module subroutine stdlib${ii}$_chpsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
!! A = L*D*L**H to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(inout) :: afp(*)
complex(sp), intent(in) :: ap(*), b(ldb,*)
complex(sp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(sp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_ccopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_chptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_clanhp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_chpcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_chptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_slamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_chpsvx
module subroutine stdlib${ii}$_zhpsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
!! A = L*D*L**H to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(inout) :: afp(*)
complex(dp), intent(in) :: ap(*), b(ldb,*)
complex(dp), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(dp) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_zcopy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_zhptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_zlanhp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_zhpcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_zhptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_dlamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_zhpsvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, &
!! ZHPSVX: uses the diagonal pivoting factorization A = U*D*U**H or
!! A = L*D*L**H to compute the solution to a complex system of linear
!! equations A * X = B, where A is an N-by-N Hermitian matrix stored
!! in packed format and X and B are N-by-NRHS matrices.
!! Error bounds on the solution and a condition estimate are also
!! provided.
berr, work, rwork, info )
! -- lapack driver routine --
! -- lapack 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) :: fact, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(inout) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(inout) :: afp(*)
complex(${ck}$), intent(in) :: ap(*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*), x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: nofact
real(${ck}$) :: anorm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
nofact = stdlib_lsame( fact, 'N' )
if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) )&
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 = -9_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPSVX', -info )
return
end if
if( nofact ) then
! compute the factorization a = u*d*u**h or a = l*d*l**h.
call stdlib${ii}$_${ci}$copy( n*( n+1 ) / 2_${ik}$, ap, 1_${ik}$, afp, 1_${ik}$ )
call stdlib${ii}$_${ci}$hptrf( uplo, n, afp, ipiv, info )
! return if info is non-zero.
if( info>0_${ik}$ )then
rcond = zero
return
end if
end if
! compute the norm of the matrix a.
anorm = stdlib${ii}$_${ci}$lanhp( 'I', uplo, n, ap, rwork )
! compute the reciprocal of the condition number of a.
call stdlib${ii}$_${ci}$hpcon( uplo, n, afp, ipiv, anorm, rcond, work, info )
! compute the solution vectors x.
call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx )
call stdlib${ii}$_${ci}$hptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info )
! use iterative refinement to improve the computed solutions and
! compute error bounds and backward error estimates for them.
call stdlib${ii}$_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, &
rwork, info )
! set info = n+1 if the matrix is singular to working precision.
if( rcond<stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) )info = n + 1_${ik}$
return
end subroutine stdlib${ii}$_${ci}$hpsvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! SSYSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_ssytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYSV_AA', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_ssytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssysv_aa
pure module subroutine stdlib${ii}$_dsysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_dsytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_dsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsysv_aa
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! DSYSV computes the solution to a real system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ri}$sytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_${ri}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYSV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_${ri}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ri}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sysv_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CSYSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_csytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSYSV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_csytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csysv_aa
pure module subroutine stdlib${ii}$_zsysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_zsytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_zsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsysv_aa
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZSYSV computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**T * T * U, if UPLO = 'U', or
!! A = L * T * L**T, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is symmetric tridiagonal. The factored
!! form of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_sytrf, lwkopt_sytrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_sytrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_sytrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_sytrf, lwkopt_sytrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSYSV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**t*t*u or a = l*t*l**t.
call stdlib${ii}$_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sysv_aa
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! CHESV_AA computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**H * T * U, if UPLO = 'U', or
!! A = L * T * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is Hermitian and tridiagonal. The factored form
!! of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max( 2_${ik}$*n, 3_${ik}$*n-2 ) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_chetrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_hetrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_chetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_hetrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_hetrf, lwkopt_hetrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHESV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**h*t*u or a = l*t*l**h.
call stdlib${ii}$_chetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_chetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chesv_aa
pure module subroutine stdlib${ii}$_zhesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV_AA computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**H * T * U, if UPLO = 'U', or
!! A = L * T * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is Hermitian and tridiagonal. The factored form
!! of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_zhetrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_hetrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_hetrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_hetrf, lwkopt_hetrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**h*t*u or a = l*t*l**h.
call stdlib${ii}$_zhetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhesv_aa
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
!! ZHESV_AA: computes the solution to a complex system of linear equations
!! A * X = B,
!! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
!! matrices.
!! Aasen's algorithm is used to factor A as
!! A = U**H * T * U, if UPLO = 'U', or
!! A = L * T * L**H, if UPLO = 'L',
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and T is Hermitian and tridiagonal. The factored form
!! of A is then used to solve the system of equations A * X = B.
! -- lapack driver routine --
! -- lapack 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, lwork, n, nrhs
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${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( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( lwork<max(2_${ik}$*n, 3_${ik}$*n-2) .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ci}$hetrf_aa( uplo, n, a, lda, ipiv, work, -1_${ik}$, info )
lwkopt_hetrf = int( work(1_${ik}$),KIND=${ik}$)
call stdlib${ii}$_${ci}$hetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,-1_${ik}$, info )
lwkopt_hetrs = int( work(1_${ik}$),KIND=${ik}$)
lwkopt = max( lwkopt_hetrf, lwkopt_hetrs )
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHESV_AA ', -info )
return
else if( lquery ) then
return
end if
! compute the factorization a = u**h*t*u or a = l*t*l**h.
call stdlib${ii}$_${ci}$hetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info )
if( info==0_${ik}$ ) then
! solve the system a*x = b, overwriting b with x.
call stdlib${ii}$_${ci}$hetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hesv_aa
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_ldl
