#:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_ldl_comp3
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_checon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! CHECON estimates the reciprocal of the condition number of a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by CHETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_checon
pure module subroutine stdlib${ii}$_zhecon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZHECON estimates the reciprocal of the condition number of a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zhecon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hecon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZHECON: estimates the reciprocal of the condition number of a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(${ck}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( anorm<zero ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHECON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do i = n, 1, -1
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$hecon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! CHETRF computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**H or A = L*D*L**H
!! 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.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRF', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_clahef;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_clahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_chetf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_clahef;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_clahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_chetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chetrf
pure module subroutine stdlib${ii}$_zhetrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZHETRF computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**H or A = L*D*L**H
!! 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.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRF', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_zlahef;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_zlahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_zhetf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_zlahef;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_zlahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_zhetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhetrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZHETRF: computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**H or A = L*D*L**H
!! 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.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRF', -info )
return
else if( lquery ) then
return
end if
nbmin = 2_${ik}$
ldwork = n
if( nb>1_${ik}$ .and. nb<n ) then
iws = ldwork*nb
if( lwork<iws ) then
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZHETRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
end if
else
iws = 1_${ik}$
end if
if( nb<nbmin )nb = n
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lahef;
! kb is either nb or nb-1, or k for the last block
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 40
if( k>nb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_${ci}$lahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_${ci}$hetf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lahef;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_${ci}$lahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_${ci}$hetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hetrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! CLAHEF computes a partial factorization of a complex Hermitian
!! matrix A using the Bunch-Kaufman diagonal pivoting method. The
!! partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
!! A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! Note that U**H denotes the conjugate transpose of U.
!! CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack 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, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(sp) :: absakk, alpha, colmax, r1, rowmax, t
complex(sp) :: d11, d21, d22, z
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11 (note that conjg(w) is actually stored)
! k is the main loop index, decreasing from n in steps of 1 or 2
k = n
10 continue
! kw is the column of w which corresponds to column k of a
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
! copy column k of a to column kw of w and update it
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( a( k, k ),KIND=sp)
if( k<n ) then
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ), lda,w( k, kw+1 ), &
ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( w( k, kw ),KIND=sp)
end if
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, kw ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=sp)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_ccopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( a( imax, imax ),KIND=sp)
call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_clacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n ) then
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda, w( imax,&
kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( w( imax, kw-1 ),KIND=sp)
end if
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = imax + stdlib${ii}$_icamax( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, kw-1 ),KIND=sp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=sp)
call stdlib${ii}$_ccopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_clacgv( kk-1-kp, a( kp, kp+1 ), lda )
if( kp>1_${ik}$ )call stdlib${ii}$_ccopy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k<n )call stdlib${ii}$_cswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
call stdlib${ii}$_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(kw) = u(k)*d(k),
! where u(k) is the k-th column of u
! (1) store subdiag. elements of column u(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element u(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,kw)
! a(1:k-1,k) := u(1:k-1,k) = w(1:k-1,kw)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=sp) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=sp)
call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
! (2) conjugate column w(kw)
call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold
! ( w(kw-1) w(kw) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! (1) store u(1:k-2,k-1) and u(1:k-2,k) and 2-by-2
! block d(k-1:k,k-1:k) in columns k-1 and k of a.
! (note: 2-by-2 diagonal block u(k-1:k,k-1:k) is a unit
! block and not stored)
! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw)
! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) =
! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) )
if( k>2_${ik}$ ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) ),
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k-1, kw )
d11 = w( k, kw ) / conjg( d21 )
d22 = w( k-1, kw-1 ) / d21
t = one / ( real( d11*d22,KIND=sp)-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = conjg( d21 )*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
! (2) conjugate columns w(kw) and w(kw-1)
call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
call stdlib${ii}$_clacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**h = a11 - u12*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=sp)
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=sp)
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in of rows in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows j and jp
! at each step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j<=n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22 (note that conjg(w) is actually stored)
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
! copy column k of a to column k of w and update it
w( k, k ) = real( a( k, k ),KIND=sp)
if( k<n )call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,&
cone, w( k, k ), 1_${ik}$ )
w( k, k ) = real( w( k, k ),KIND=sp)
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, k ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_icamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=sp)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_clacgv( imax-k, w( k, k+1 ), 1_${ik}$ )
w( imax, k+1 ) = real( a( imax, imax ),KIND=sp)
if( imax<n )call stdlib${ii}$_ccopy( n-imax, a( imax+1, imax ), 1_${ik}$,w( imax+1, k+1 ), &
1_${ik}$ )
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ )
w( imax, k+1 ) = real( w( imax, k+1 ),KIND=sp)
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_icamax( n-imax, w( imax+1, k+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, k+1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, k+1 ),KIND=sp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=sp)
call stdlib${ii}$_ccopy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
call stdlib${ii}$_clacgv( kp-kk-1, a( kp, kk+1 ), lda )
if( kp<n )call stdlib${ii}$_ccopy( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
! interchange rows kk and kp in first k-1 columns of a
! (columns k (or k and k+1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in first kk columns of w.
if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! (1) store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=sp) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=sp)
call stdlib${ii}$_csscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
! (2) conjugate column w(k)
call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! (1) store l(k+2:n,k) and l(k+2:n,k+1) and 2-by-2
! block d(k:k+1,k:k+1) in columns k and k+1 of a.
! (note: 2-by-2 diagonal block l(k:k+1,k:k+1) is a unit
! block and not stored)
! a(k:k+1,k:k+1) := d(k:k+1,k:k+1) = w(k:k+1,k:k+1)
! a(k+2:n,k:k+1) := l(k+2:n,k:k+1) =
! = w(k+2:n,k:k+1) * ( d(k:k+1,k:k+1)**(-1) )
if( k<n-1 ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) )
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / conjg( d21 )
t = one / ( real( d11*d22,KIND=sp)-one )
d21 = t / d21
! update elements in columns a(k) and a(k+1) as
! dot products of rows of ( w(k) w(k+1) ) and columns
! of d**(-1)
do j = k + 2, n
a( j, k ) = conjg( d21 )*( d11*w( j, k )-w( j, k+1 ) )
a( j, k+1 ) = d21*( d22*w( j, k+1 )-w( j, k ) )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
! (2) conjugate columns w(k) and w(k+1)
call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**h = a22 - l21*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=sp)
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=sp)
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! of rows in columns 1:k-1 looping backwards from k-1 to 1
j = k - 1_${ik}$
120 continue
! undo the interchanges (if any) of rows j and jp
! at each step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j - 1_${ik}$
end if
! (note: here, j is used to determine row length. length j
! of the rows to swap back doesn't include diagonal element)
j = j - 1_${ik}$
if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
if( j>=1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_clahef
pure module subroutine stdlib${ii}$_zlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! ZLAHEF computes a partial factorization of a complex Hermitian
!! matrix A using the Bunch-Kaufman diagonal pivoting method. The
!! partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
!! A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! Note that U**H denotes the conjugate transpose of U.
!! ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack 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, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(dp) :: absakk, alpha, colmax, r1, rowmax, t
complex(dp) :: d11, d21, d22, z
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11 (note that conjg(w) is actually stored)
! k is the main loop index, decreasing from n in steps of 1 or 2
! kw is the column of w which corresponds to column k of a
k = n
10 continue
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
! copy column k of a to column kw of w and update it
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( a( k, k ),KIND=dp)
if( k<n ) then
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ), lda,w( k, kw+1 ), &
ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( w( k, kw ),KIND=dp)
end if
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, kw ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=dp)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_zcopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( a( imax, imax ),KIND=dp)
call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n ) then
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda, w( imax,&
kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( w( imax, kw-1 ),KIND=dp)
end if
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = imax + stdlib${ii}$_izamax( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, kw-1 ),KIND=dp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=dp)
call stdlib${ii}$_zcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_zlacgv( kk-1-kp, a( kp, kp+1 ), lda )
if( kp>1_${ik}$ )call stdlib${ii}$_zcopy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k<n )call stdlib${ii}$_zswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
call stdlib${ii}$_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(kw) = u(k)*d(k),
! where u(k) is the k-th column of u
! (1) store subdiag. elements of column u(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element u(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,kw)
! a(1:k-1,k) := u(1:k-1,k) = w(1:k-1,kw)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=dp) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
! (2) conjugate column w(kw)
call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold
! ( w(kw-1) w(kw) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! (1) store u(1:k-2,k-1) and u(1:k-2,k) and 2-by-2
! block d(k-1:k,k-1:k) in columns k-1 and k of a.
! (note: 2-by-2 diagonal block u(k-1:k,k-1:k) is a unit
! block and not stored)
! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw)
! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) =
! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) )
if( k>2_${ik}$ ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) ),
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k-1, kw )
d11 = w( k, kw ) / conjg( d21 )
d22 = w( k-1, kw-1 ) / d21
t = one / ( real( d11*d22,KIND=dp)-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = conjg( d21 )*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
! (2) conjugate columns w(kw) and w(kw-1)
call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**h = a11 - u12*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=dp)
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=dp)
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j<n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22 (note that conjg(w) is actually stored)
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
! copy column k of a to column k of w and update it
w( k, k ) = real( a( k, k ),KIND=dp)
if( k<n )call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,&
cone, w( k, k ), 1_${ik}$ )
w( k, k ) = real( w( k, k ),KIND=dp)
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, k ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_izamax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=dp)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( imax-k, w( k, k+1 ), 1_${ik}$ )
w( imax, k+1 ) = real( a( imax, imax ),KIND=dp)
if( imax<n )call stdlib${ii}$_zcopy( n-imax, a( imax+1, imax ), 1_${ik}$,w( imax+1, k+1 ), &
1_${ik}$ )
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ )
w( imax, k+1 ) = real( w( imax, k+1 ),KIND=dp)
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_izamax( n-imax, w( imax+1, k+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, k+1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, k+1 ),KIND=dp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=dp)
call stdlib${ii}$_zcopy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
call stdlib${ii}$_zlacgv( kp-kk-1, a( kp, kk+1 ), lda )
if( kp<n )call stdlib${ii}$_zcopy( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
! interchange rows kk and kp in first k-1 columns of a
! (columns k (or k and k+1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in first kk columns of w.
if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! (1) store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=dp) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zdscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
! (2) conjugate column w(k)
call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! (1) store l(k+2:n,k) and l(k+2:n,k+1) and 2-by-2
! block d(k:k+1,k:k+1) in columns k and k+1 of a.
! (note: 2-by-2 diagonal block l(k:k+1,k:k+1) is a unit
! block and not stored)
! a(k:k+1,k:k+1) := d(k:k+1,k:k+1) = w(k:k+1,k:k+1)
! a(k+2:n,k:k+1) := l(k+2:n,k:k+1) =
! = w(k+2:n,k:k+1) * ( d(k:k+1,k:k+1)**(-1) )
if( k<n-1 ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) ),
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / conjg( d21 )
t = one / ( real( d11*d22,KIND=dp)-one )
d21 = t / d21
! update elements in columns a(k) and a(k+1) as
! dot products of rows of ( w(k) w(k+1) ) and columns
! of d**(-1)
do j = k + 2, n
a( j, k ) = conjg( d21 )*( d11*w( j, k )-w( j, k+1 ) )
a( j, k+1 ) = d21*( d22*w( j, k+1 )-w( j, k ) )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
! (2) conjugate columns w(k) and w(k+1)
call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**h = a22 - l21*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=dp)
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=dp)
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! of rows in columns 1:k-1 looping backwards from k-1 to 1
j = k - 1_${ik}$
120 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j - 1_${ik}$
end if
! (note: here, j is used to determine row length. length j
! of the rows to swap back doesn't include diagonal element)
j = j - 1_${ik}$
if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
if( j>1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_zlahef
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$lahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! ZLAHEF: computes a partial factorization of a complex Hermitian
!! matrix A using the Bunch-Kaufman diagonal pivoting method. The
!! partial factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
!! A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! Note that U**H denotes the conjugate transpose of U.
!! ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack 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, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(${ck}$) :: absakk, alpha, colmax, r1, rowmax, t
complex(${ck}$) :: d11, d21, d22, z
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) )
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11 (note that conjg(w) is actually stored)
! k is the main loop index, decreasing from n in steps of 1 or 2
! kw is the column of w which corresponds to column k of a
k = n
10 continue
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb<n ) .or. k<1 )go to 30
kstep = 1_${ik}$
! copy column k of a to column kw of w and update it
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( a( k, k ),KIND=${ck}$)
if( k<n ) then
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone, a( 1_${ik}$, k+1 ), lda,w( k, kw+1 ), &
ldw, cone, w( 1_${ik}$, kw ), 1_${ik}$ )
w( k, kw ) = real( w( k, kw ),KIND=${ck}$)
end if
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, kw ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = cabs1( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=${ck}$)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_${ci}$copy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$)
call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
if( k<n ) then
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', k, n-k, -cone,a( 1_${ik}$, k+1 ), lda, w( imax,&
kw+1 ), ldw,cone, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
w( imax, kw-1 ) = real( w( imax, kw-1 ),KIND=${ck}$)
end if
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, w( imax+1, kw-1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, kw-1 ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, kw-1 ),KIND=${ck}$) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$)
call stdlib${ii}$_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
call stdlib${ii}$_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda )
if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$copy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k<n )call stdlib${ii}$_${ci}$swap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),lda )
call stdlib${ii}$_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column kw of w now holds
! w(kw) = u(k)*d(k),
! where u(k) is the k-th column of u
! (1) store subdiag. elements of column u(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element u(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,kw)
! a(1:k-1,k) := u(1:k-1,k) = w(1:k-1,kw)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ )
if( k>1_${ik}$ ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
! (2) conjugate column w(kw)
call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold
! ( w(kw-1) w(kw) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! (1) store u(1:k-2,k-1) and u(1:k-2,k) and 2-by-2
! block d(k-1:k,k-1:k) in columns k-1 and k of a.
! (note: 2-by-2 diagonal block u(k-1:k,k-1:k) is a unit
! block and not stored)
! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw)
! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) =
! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) )
if( k>2_${ik}$ ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) ),
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k-1, kw )
d11 = w( k, kw ) / conjg( d21 )
d22 = w( k-1, kw-1 ) / d21
t = one / ( real( d11*d22,KIND=${ck}$)-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = conjg( d21 )*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
! (2) conjugate columns w(kw) and w(kw-1)
call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**h = a11 - u12*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$)
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,&
kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$)
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j<n )go to 60
! set kb to the number of columns factorized
kb = n - k
else
! factorize the leading columns of a using the lower triangle
! of a and working forwards, and compute the matrix w = l21*d
! for use in updating a22 (note that conjg(w) is actually stored)
! k is the main loop index, increasing from 1 in steps of 1 or 2
k = 1_${ik}$
70 continue
! exit from loop
if( ( k>=nb .and. nb<n ) .or. k>n )go to 90
kstep = 1_${ik}$
! copy column k of a to column k of w and update it
w( k, k ) = real( a( k, k ),KIND=${ck}$)
if( k<n )call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,&
cone, w( k, k ), 1_${ik}$ )
w( k, k ) = real( w( k, k ),KIND=${ck}$)
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( w( k, k ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ci}$amax( n-k, w( k+1, k ), 1_${ik}$ )
colmax = cabs1( w( imax, k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=${ck}$)
else
! ============================================================
! begin pivot search
! case(1)
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! begin pivot search along imax row
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( imax-k, w( k, k+1 ), 1_${ik}$ )
w( imax, k+1 ) = real( a( imax, imax ),KIND=${ck}$)
if( imax<n )call stdlib${ii}$_${ci}$copy( n-imax, a( imax+1, imax ), 1_${ik}$,w( imax+1, k+1 ), &
1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ )
w( imax, k+1 ) = real( w( imax, k+1 ),KIND=${ck}$)
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = cabs1( w( jmax, k+1 ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_i${ci}$amax( n-imax, w( imax+1, k+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( w( jmax, k+1 ) ) )
end if
! case(2)
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
! case(3)
else if( abs( real( w( imax, k+1 ),KIND=${ck}$) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
! case(4)
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
! end pivot search along imax row
end if
! end pivot search
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$)
call stdlib${ii}$_${ci}$copy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
call stdlib${ii}$_${ci}$lacgv( kp-kk-1, a( kp, kk+1 ), lda )
if( kp<n )call stdlib${ii}$_${ci}$copy( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
! interchange rows kk and kp in first k-1 columns of a
! (columns k (or k and k+1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in first kk columns of w.
if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! (1) store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
! (note: no need to use for hermitian matrix
! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal
! element d(k,k) from w (potentially saves only one load))
call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k<n ) then
! (note: no need to check if a(k,k) is not zero,
! since that was ensured earlier in pivot search:
! case a(k,k) = 0 falls into 2x2 pivot case(4))
r1 = one / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
! (2) conjugate column w(k)
call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 of w now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
! (1) store l(k+2:n,k) and l(k+2:n,k+1) and 2-by-2
! block d(k:k+1,k:k+1) in columns k and k+1 of a.
! (note: 2-by-2 diagonal block l(k:k+1,k:k+1) is a unit
! block and not stored)
! a(k:k+1,k:k+1) := d(k:k+1,k:k+1) = w(k:k+1,k:k+1)
! a(k+2:n,k:k+1) := l(k+2:n,k:k+1) =
! = w(k+2:n,k:k+1) * ( d(k:k+1,k:k+1)**(-1) )
if( k<n-1 ) then
! factor out the columns of the inverse of 2-by-2 pivot
! block d, so that each column contains 1, to reduce the
! number of flops when we multiply panel
! ( w(kw-1) w(kw) ) by this inverse, i.e. by d**(-1).
! d**(-1) = ( d11 cj(d21) )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
! ( (-d21) ( d11 ) )
! = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
! * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
! ( ( -1 ) ( d11/conj(d21) ) )
! = 1/(|d21|**2) * 1/(d22*d11-1) *
! * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = (1/|d21|**2) * t * ( d21*( d11 ) conj(d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( (t/conj(d21))*( d11 ) (t/d21)*( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = ( conj(d21)*( d11 ) d21*( -1 ) )
! ( ( -1 ) ( d22 ) ),
! where d11 = d22/d21,
! d22 = d11/conj(d21),
! d21 = t/d21,
! t = 1/(d22*d11-1).
! (note: no need to check for division by zero,
! since that was ensured earlier in pivot search:
! (a) d21 != 0, since in 2x2 pivot case(4)
! |d21| should be larger than |d11| and |d22|;
! (b) (d22*d11 - 1) != 0, since from (a),
! both |d11| < 1, |d22| < 1, hence |d22*d11| << 1.)
d21 = w( k+1, k )
d11 = w( k+1, k+1 ) / d21
d22 = w( k, k ) / conjg( d21 )
t = one / ( real( d11*d22,KIND=${ck}$)-one )
d21 = t / d21
! update elements in columns a(k) and a(k+1) as
! dot products of rows of ( w(k) w(k+1) ) and columns
! of d**(-1)
do j = k + 2, n
a( j, k ) = conjg( d21 )*( d11*w( j, k )-w( j, k+1 ) )
a( j, k+1 ) = d21*( d22*w( j, k+1 )-w( j, k ) )
end do
end if
! copy d(k) to a
a( k, k ) = w( k, k )
a( k+1, k ) = w( k+1, k )
a( k+1, k+1 ) = w( k+1, k+1 )
! (2) conjugate columns w(k) and w(k+1)
call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 70
90 continue
! update the lower triangle of a22 (= a(k:n,k:n)) as
! a22 := a22 - l21*d*l21**h = a22 - l21*w**h
! computing blocks of nb columns at a time (note that conjg(w) is
! actually stored)
do j = k, n, nb
jb = min( nb, n-j+1 )
! update the lower triangle of the diagonal block
do jj = j, j + jb - 1
a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$)
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,&
1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ )
a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$)
end do
! update the rectangular subdiagonal block
if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -&
cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda )
end do
! put l21 in standard form by partially undoing the interchanges
! of rows in columns 1:k-1 looping backwards from k-1 to 1
j = k - 1_${ik}$
120 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j - 1_${ik}$
end if
! (note: here, j is used to determine row length. length j
! of the rows to swap back doesn't include diagonal element)
j = j - 1_${ik}$
if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
if( j>1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ci}$lahef
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetf2( uplo, n, a, lda, ipiv, info )
!! CHETF2 computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**H is the conjugate transpose of U, and D is
!! Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kk, kp, kstep
real(sp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(sp) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETF2', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_sisnan(absakk) ) then
! column k is or underflow, or contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=sp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=sp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, kk - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=sp)
a( kk, kk ) = real( a( kp, kp ),KIND=sp)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=sp)
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=sp)
if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=sp)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( a( k, k ),KIND=sp)
call stdlib${ii}$_cher( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) )
d22 = real( a( k-1, k-1 ),KIND=sp) / d
d11 = real( a( k, k ),KIND=sp) / d
tt = one / ( d11*d22-one )
d12 = a( k-1, k ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*a( j, k-1 )-conjg( d12 )*a( j, k ) )
wk = d*( d22*a( j, k )-d12*a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k-1 )*conjg( &
wkm1 )
end do
a( j, k ) = wk
a( j, k-1 ) = wkm1
a( j, j ) = cmplx( real( a( j, j ),KIND=sp), zero,KIND=sp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
50 continue
! if k > n, exit from loop
if( k>n )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_icamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_sisnan(absakk) ) then
! column k is zero or underflow, contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=sp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_icamax( n-imax, a( imax+1, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=sp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = kk + 1, kp - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=sp)
a( kk, kk ) = real( a( kp, kp ),KIND=sp)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=sp)
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=sp)
if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=sp)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( a( k, k ),KIND=sp)
call stdlib${ii}$_cher( uplo, n-k, -r1, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_csscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k)
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_slapy2( real( a( k+1, k ),KIND=sp),aimag( a( k+1, k ) ) )
d11 = real( a( k+1, k+1 ),KIND=sp) / d
d22 = real( a( k, k ),KIND=sp) / d
tt = one / ( d11*d22-one )
d21 = a( k+1, k ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*a( j, k )-d21*a( j, k+1 ) )
wkp1 = d*( d22*a( j, k+1 )-conjg( d21 )*a( j, k ) )
do i = j, n
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k+1 )*conjg( &
wkp1 )
end do
a( j, k ) = wk
a( j, k+1 ) = wkp1
a( j, j ) = cmplx( real( a( j, j ),KIND=sp), zero,KIND=sp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 50
end if
90 continue
return
end subroutine stdlib${ii}$_chetf2
pure module subroutine stdlib${ii}$_zhetf2( uplo, n, a, lda, ipiv, info )
!! ZHETF2 computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**H is the conjugate transpose of U, and D is
!! Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kk, kp, kstep
real(dp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(dp) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETF2', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_disnan(absakk) ) then
! column k is zero or underflow, or contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=dp)
else
! ============================================================
! test for interchange
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=dp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, kk - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=dp)
a( kk, kk ) = real( a( kp, kp ),KIND=dp)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=dp)
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=dp)
if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=dp)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zher( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) )
d22 = real( a( k-1, k-1 ),KIND=dp) / d
d11 = real( a( k, k ),KIND=dp) / d
tt = one / ( d11*d22-one )
d12 = a( k-1, k ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*a( j, k-1 )-conjg( d12 )*a( j, k ) )
wk = d*( d22*a( j, k )-d12*a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k-1 )*conjg( &
wkm1 )
end do
a( j, k ) = wk
a( j, k-1 ) = wkm1
a( j, j ) = cmplx( real( a( j, j ),KIND=dp), zero,KIND=dp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
50 continue
! if k > n, exit from loop
if( k>n )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_izamax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_disnan(absakk) ) then
! column k is zero or underflow, or contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=dp)
else
! ============================================================
! test for interchange
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_izamax( n-imax, a( imax+1, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=dp) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = kk + 1, kp - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=dp)
a( kk, kk ) = real( a( kp, kp ),KIND=dp)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=dp)
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=dp)
if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=dp)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zher( uplo, n-k, -r1, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_zdscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k)
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_dlapy2( real( a( k+1, k ),KIND=dp),aimag( a( k+1, k ) ) )
d11 = real( a( k+1, k+1 ),KIND=dp) / d
d22 = real( a( k, k ),KIND=dp) / d
tt = one / ( d11*d22-one )
d21 = a( k+1, k ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*a( j, k )-d21*a( j, k+1 ) )
wkp1 = d*( d22*a( j, k+1 )-conjg( d21 )*a( j, k ) )
do i = j, n
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k+1 )*conjg( &
wkp1 )
end do
a( j, k ) = wk
a( j, k+1 ) = wkp1
a( j, j ) = cmplx( real( a( j, j ),KIND=dp), zero,KIND=dp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 50
end if
90 continue
return
end subroutine stdlib${ii}$_zhetf2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetf2( uplo, n, a, lda, ipiv, info )
!! ZHETF2: computes the factorization of a complex Hermitian matrix A
!! using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, U**H is the conjugate transpose of U, and D is
!! Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!! This is the unblocked version of the algorithm, calling Level 2 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kk, kp, kstep
real(${ck}$) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(${ck}$) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETF2', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
10 continue
! if k < 1, exit from loop
if( k<1 )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_${c2ri(ci)}$isnan(absakk) ) then
! column k is zero or underflow, or contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=${ck}$)
else
! ============================================================
! test for interchange
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=${ck}$) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
kk = k - kstep + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, kk - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=${ck}$)
a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=${ck}$)
t = a( k-1, k )
a( k-1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=${ck}$)
if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$her( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda )
! store u(k) in column k
call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) )
d22 = real( a( k-1, k-1 ),KIND=${ck}$) / d
d11 = real( a( k, k ),KIND=${ck}$) / d
tt = one / ( d11*d22-one )
d12 = a( k-1, k ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*a( j, k-1 )-conjg( d12 )*a( j, k ) )
wk = d*( d22*a( j, k )-d12*a( j, k-1 ) )
do i = j, 1, -1
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k-1 )*conjg( &
wkm1 )
end do
a( j, k ) = wk
a( j, k-1 ) = wkm1
a( j, j ) = cmplx( real( a( j, j ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
50 continue
! if k > n, exit from loop
if( k>n )go to 90
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( a( k, k ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k<n ) then
imax = k + stdlib${ii}$_i${ci}$amax( n-k, a( k+1, k ), 1_${ik}$ )
colmax = cabs1( a( imax, k ) )
else
colmax = zero
end if
if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_${c2ri(ci)}$isnan(absakk) ) then
! column k is zero or underflow, or contains a nan:
! set info and continue
if( info==0_${ik}$ )info = k
kp = k
a( k, k ) = real( a( k, k ),KIND=${ck}$)
else
! ============================================================
! test for interchange
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value.
! determine only rowmax.
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, a( imax, k ), lda )
rowmax = cabs1( a( imax, jmax ) )
if( imax<n ) then
jmax = imax + stdlib${ii}$_i${ci}$amax( n-imax, a( imax+1, imax ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( a( imax, imax ),KIND=${ck}$) )>=alpha*rowmax )then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
kk = k + kstep - 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, kk ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = kk + 1, kp - 1
t = conjg( a( j, kk ) )
a( j, kk ) = conjg( a( kp, j ) )
a( kp, j ) = t
end do
a( kp, kk ) = conjg( a( kp, kk ) )
r1 = real( a( kk, kk ),KIND=${ck}$)
a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$)
a( kp, kp ) = r1
if( kstep==2_${ik}$ ) then
a( k, k ) = real( a( k, k ),KIND=${ck}$)
t = a( k+1, k )
a( k+1, k ) = a( kp, k )
a( kp, k ) = t
end if
else
a( k, k ) = real( a( k, k ),KIND=${ck}$)
if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=${ck}$)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$her( uplo, n-k, -r1, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda )
! store l(k) in column k
call stdlib${ii}$_${ci}$dscal( n-k, r1, a( k+1, k ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k)
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( a( k+1, k ),KIND=${ck}$),aimag( a( k+1, k ) ) )
d11 = real( a( k+1, k+1 ),KIND=${ck}$) / d
d22 = real( a( k, k ),KIND=${ck}$) / d
tt = one / ( d11*d22-one )
d21 = a( k+1, k ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*a( j, k )-d21*a( j, k+1 ) )
wkp1 = d*( d22*a( j, k+1 )-conjg( d21 )*a( j, k ) )
do i = j, n
a( i, j ) = a( i, j ) - a( i, k )*conjg( wk ) -a( i, k+1 )*conjg( &
wkp1 )
end do
a( j, k ) = wk
a( j, k+1 ) = wkp1
a( j, j ) = cmplx( real( a( j, j ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
go to 50
end if
90 continue
return
end subroutine stdlib${ii}$_${ci}$hetf2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
!! CHETRS solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by CHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(sp) :: s
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=sp) / real( a( k, k ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )&
, 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=sp) / real( a( k, k ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / conjg( akm1k )
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k-1 ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_chetrs
pure module subroutine stdlib${ii}$_zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
!! ZHETRS solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(dp) :: s
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=dp) / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )&
, 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=dp) / real( a( k, k ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / conjg( akm1k )
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k-1 ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_zhetrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info )
!! ZHETRS: solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp
real(${ck}$) :: s
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=${ck}$) / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb &
)
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), &
ldb )
! multiply by the inverse of the diagonal block.
akm1k = a( k-1, k )
akm1 = a( k-1, k-1 ) / akm1k
ak = a( k, k ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )&
, 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, a( k+1, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( &
k+1, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=${ck}$) / real( a( k, k ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, a( k+2, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, a( k+2, k+1 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = a( k+1, k )
akm1 = a( k, k ) / conjg( akm1k )
ak = a( k+1, k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
a( k+1, k-1 ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ci}$hetrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetri( uplo, n, a, lda, ipiv, work, info )
!! CHETRI computes the inverse of a complex Hermitian indefinite matrix
!! A using the factorization A = U*D*U**H or A = L*D*L**H computed by
!! CHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp, kstep
real(sp) :: ak, akp1, d, t
complex(sp) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=sp)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=sp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = real( a( k, k ),KIND=sp) / t
akp1 = real( a( k+1, k+1 ),KIND=sp) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=sp)
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),&
1_${ik}$ ),KIND=sp)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, k - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
end if
k = k + kstep
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=sp)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=sp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = real( a( k-1, k-1 ),KIND=sp) / t
akp1 = real( a( k, k ),KIND=sp) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=sp)
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_cdotc( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_ccopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$, a( k+1, k-1 )&
,1_${ik}$ ),KIND=sp)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
if( kp<n )call stdlib${ii}$_cswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = k + 1, kp - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
end if
k = k - kstep
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_chetri
pure module subroutine stdlib${ii}$_zhetri( uplo, n, a, lda, ipiv, work, info )
!! ZHETRI computes the inverse of a complex Hermitian indefinite matrix
!! A using the factorization A = U*D*U**H or A = L*D*L**H computed by
!! ZHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp, kstep
real(dp) :: ak, akp1, d, t
complex(dp) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=dp)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=dp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = real( a( k, k ),KIND=dp) / t
akp1 = real( a( k+1, k+1 ),KIND=dp) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=dp)
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),&
1_${ik}$ ),KIND=dp)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, k - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
end if
k = k + kstep
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=dp)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=dp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = real( a( k-1, k-1 ),KIND=dp) / t
akp1 = real( a( k, k ),KIND=dp) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=dp)
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_zdotc( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_zcopy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$, a( k+1, k-1 )&
,1_${ik}$ ),KIND=dp)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
if( kp<n )call stdlib${ii}$_zswap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = k + 1, kp - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
end if
k = k - kstep
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_zhetri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetri( uplo, n, a, lda, ipiv, work, info )
!! ZHETRI: computes the inverse of a complex Hermitian indefinite matrix
!! A using the factorization A = U*D*U**H or A = L*D*L**H computed by
!! ZHETRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kp, kstep
real(${ck}$) :: ak, akp1, d, t
complex(${ck}$) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
do info = n, 1, -1
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do info = 1, n
if( ipiv( info )>0 .and. a( info, info )==czero )return
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=${ck}$)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=${ck}$)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k+1 ) )
ak = real( a( k, k ),KIND=${ck}$) / t
akp1 = real( a( k+1, k+1 ),KIND=${ck}$) / t
akkp1 = a( k, k+1 ) / t
d = t*( ak*akp1-one )
a( k, k ) = akp1 / d
a( k+1, k+1 ) = ak / d
a( k, k+1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),&
KIND=${ck}$)
a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ )
a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),&
1_${ik}$ ),KIND=${ck}$)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
do j = kp + 1, k - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k+1 )
a( k, k+1 ) = a( kp, k+1 )
a( kp, k+1 ) = temp
end if
end if
k = k + kstep
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
a( k, k ) = one / real( a( k, k ),KIND=${ck}$)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=${ck}$)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( a( k, k-1 ) )
ak = real( a( k-1, k-1 ),KIND=${ck}$) / t
akp1 = real( a( k, k ),KIND=${ck}$) / t
akkp1 = a( k, k-1 ) / t
d = t*( ak*akp1-one )
a( k-1, k-1 ) = akp1 / d
a( k, k ) = ak / d
a( k, k-1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k ), 1_${ik}$ )
a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$,a( k+1, k ), 1_${ik}$ ),&
KIND=${ck}$)
a( k, k-1 ) = a( k, k-1 ) -stdlib${ii}$_${ci}$dotc( n-k, a( k+1, k ), 1_${ik}$, a( k+1, k-1 ),1_${ik}$ &
)
call stdlib${ii}$_${ci}$copy( n-k, a( k+1, k-1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,1_${ik}$, czero, a( k+&
1_${ik}$, k-1 ), 1_${ik}$ )
a( k-1, k-1 ) = a( k-1, k-1 ) -real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$, a( k+1, k-1 )&
,1_${ik}$ ),KIND=${ck}$)
end if
kstep = 2_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, a( kp+1, k ), 1_${ik}$, a( kp+1, kp ), 1_${ik}$ )
do j = k + 1, kp - 1
temp = conjg( a( j, k ) )
a( j, k ) = conjg( a( kp, j ) )
a( kp, j ) = temp
end do
a( kp, k ) = conjg( a( kp, k ) )
temp = a( k, k )
a( k, k ) = a( kp, kp )
a( kp, kp ) = temp
if( kstep==2_${ik}$ ) then
temp = a( k, k-1 )
a( k, k-1 ) = a( kp, k-1 )
a( kp, k-1 ) = temp
end if
end if
k = k - kstep
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_${ci}$hetri
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! CHERFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian indefinite, and
!! provides error bounds and backward error estimates for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(sp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(sp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_slamch( 'EPSILON' )
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_ccopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=sp) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_clacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_cherfs
pure module subroutine stdlib${ii}$_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! ZHERFS improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian indefinite, and
!! provides error bounds and backward error estimates for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(dp), intent(out) :: berr(*), ferr(*), rwork(*)
complex(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(dp) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_dlamch( 'EPSILON' )
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_zcopy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=dp) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_zlacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_zherfs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, &
!! ZHERFS: improves the computed solution to a system of linear
!! equations when the coefficient matrix is Hermitian indefinite, and
!! provides error bounds and backward error estimates for the solution.
berr, work, rwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*)
complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: x(ldx,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: itmax = 5_${ik}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: count, i, j, k, kase, nz
real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk
complex(${ck}$) :: zdum
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldaf<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -10_${ik}$
else if( ldx<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHERFS', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. nrhs==0_${ik}$ ) then
do j = 1, nrhs
ferr( j ) = zero
berr( j ) = zero
end do
return
end if
! nz = maximum number of nonzero elements in each row of a, plus 1
nz = n + 1_${ik}$
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
safe1 = nz*safmin
safe2 = safe1 / eps
! do for each right hand side
loop_140: do j = 1, nrhs
count = 1_${ik}$
lstres = three
20 continue
! loop until stopping criterion is satisfied.
! compute residual r = b - a * x
call stdlib${ii}$_${ci}$copy( n, b( 1_${ik}$, j ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hemv( uplo, n, -cone, a, lda, x( 1_${ik}$, j ), 1_${ik}$, cone, work, 1_${ik}$ )
! compute componentwise relative backward error from formula
! max(i) ( abs(r(i)) / ( abs(a)*abs(x) + abs(b) )(i) )
! where abs(z) is the componentwise absolute value of the matrix
! or vector z. if the i-th component of the denominator is less
! than safe2, then safe1 is added to the i-th components of the
! numerator and denominator before dividing.
do i = 1, n
rwork( i ) = cabs1( b( i, j ) )
end do
! compute abs(a)*abs(x) + abs(b).
if( upper ) then
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
do i = 1, k - 1
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk + s
end do
else
do k = 1, n
s = zero
xk = cabs1( x( k, j ) )
rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk
do i = k + 1, n
rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
end do
rwork( k ) = rwork( k ) + s
end do
end if
s = zero
do i = 1, n
if( rwork( i )>safe2 ) then
s = max( s, cabs1( work( i ) ) / rwork( i ) )
else
s = max( s, ( cabs1( work( i ) )+safe1 ) /( rwork( i )+safe1 ) )
end if
end do
berr( j ) = s
! test stopping criterion. continue iterating if
! 1) the residual berr(j) is larger than machine epsilon, and
! 2) berr(j) decreased by at least a factor of 2 during the
! last iteration, and
! 3) at most itmax iterations tried.
if( berr( j )>eps .and. two*berr( j )<=lstres .and.count<=itmax ) then
! update solution and try again.
call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ )
lstres = berr( j )
count = count + 1_${ik}$
go to 20
end if
! bound error from formula
! norm(x - xtrue) / norm(x) .le. ferr =
! norm( abs(inv(a))*
! ( abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) ))) / norm(x)
! where
! norm(z) is the magnitude of the largest component of z
! inv(a) is the inverse of a
! abs(z) is the componentwise absolute value of the matrix or
! vector z
! nz is the maximum number of nonzeros in any row of a, plus 1
! eps is machine epsilon
! the i-th component of abs(r)+nz*eps*(abs(a)*abs(x)+abs(b))
! is incremented by safe1 if the i-th component of
! abs(a)*abs(x) + abs(b) is less than safe2.
! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix
! inv(a) * diag(w),
! where w = abs(r) + nz*eps*( abs(a)*abs(x)+abs(b) )))
do i = 1, n
if( rwork( i )>safe2 ) then
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
else
rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1
end if
end do
kase = 0_${ik}$
100 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! multiply by diag(w)*inv(a**h).
call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
else if( kase==2_${ik}$ ) then
! multiply by inv(a)*diag(w).
do i = 1, n
work( i ) = rwork( i )*work( i )
end do
call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info )
end if
go to 100
end if
! normalize error.
lstres = zero
do i = 1, n
lstres = max( lstres, cabs1( x( i, j ) ) )
end do
if( lstres/=zero )ferr( j ) = ferr( j ) / lstres
end do loop_140
return
end subroutine stdlib${ii}$_${ci}$herfs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cheequb( uplo, n, a, lda, s, scond, amax, work, info )
!! CHEEQUB computes row and column scalings intended to equilibrate a
!! Hermitian matrix A (with respect to the Euclidean norm) and reduce
!! its condition number. The scale factors S are computed by the BIN
!! algorithm (see references) so that the scaled matrix B with elements
!! B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(out) :: amax, scond
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(out) :: work(*)
real(sp), intent(out) :: s(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: max_iter = 100_${ik}$
! Local Scalars
integer(${ik}$) :: i, j, iter
real(sp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, &
scale, sumsq
logical(lk) :: up
complex(sp) :: zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not. ( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -1_${ik}$
else if ( n < 0_${ik}$ ) then
info = -2_${ik}$
else if ( lda < max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if ( info /= 0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEEQUB', -info )
return
end if
up = stdlib_lsame( uplo, 'U' )
amax = zero
! quick return if possible.
if ( n == 0_${ik}$ ) then
scond = one
return
end if
do i = 1, n
s( i ) = zero
end do
amax = zero
if ( up ) then
do j = 1, n
do i = 1, j-1
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
end do
else
do j = 1, n
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
do i = j+1, n
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
end do
end if
do j = 1, n
s( j ) = one / s( j )
end do
tol = one / sqrt( two * n )
do iter = 1, max_iter
scale = zero
sumsq = zero
! beta = |a|s
do i = 1, n
work( i ) = zero
end do
if ( up ) then
do j = 1, n
do i = 1, j-1
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
end do
else
do j = 1, n
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
do i = j+1, n
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
end do
end if
! avg = s^t beta / n
avg = zero
do i = 1, n
avg = avg + real( s( i )*work( i ),KIND=sp)
end do
avg = avg / n
std = zero
do i = n+1, 2*n
work( i ) = s( i-n ) * work( i-n ) - avg
end do
call stdlib${ii}$_classq( n, work( n+1 ), 1_${ik}$, scale, sumsq )
std = scale * sqrt( sumsq / n )
if ( std < tol * avg ) goto 999
do i = 1, n
t = cabs1( a( i, i ) )
si = s( i )
c2 = ( n-1 ) * t
c1 = real( ( n-2 ) * ( work( i ) - t*si ),KIND=sp)
c0 = real( -(t*si)*si + 2_${ik}$*work( i )*si - n*avg,KIND=sp)
d = c1*c1 - 4_${ik}$*c0*c2
if ( d <= 0_${ik}$ ) then
info = -1_${ik}$
return
end if
si = -2_${ik}$*c0 / ( c1 + sqrt( d ) )
d = si - s( i )
u = zero
if ( up ) then
do j = 1, i
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
else
do j = 1, i
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
end if
avg = avg + real( ( u + work( i ) ) * d / n,KIND=sp)
s( i ) = si
end do
end do
999 continue
smlnum = stdlib${ii}$_slamch( 'SAFEMIN' )
bignum = one / smlnum
smin = bignum
smax = zero
t = one / sqrt( avg )
base = stdlib${ii}$_slamch( 'B' )
u = one / log( base )
do i = 1, n
s( i ) = base ** int( u * log( s( i ) * t ),KIND=${ik}$)
smin = min( smin, s( i ) )
smax = max( smax, s( i ) )
end do
scond = max( smin, smlnum ) / min( smax, bignum )
end subroutine stdlib${ii}$_cheequb
pure module subroutine stdlib${ii}$_zheequb( uplo, n, a, lda, s, scond, amax, work, info )
!! ZHEEQUB computes row and column scalings intended to equilibrate a
!! Hermitian matrix A (with respect to the Euclidean norm) and reduce
!! its condition number. The scale factors S are computed by the BIN
!! algorithm (see references) so that the scaled matrix B with elements
!! B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(out) :: amax, scond
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(out) :: work(*)
real(dp), intent(out) :: s(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: max_iter = 100_${ik}$
! Local Scalars
integer(${ik}$) :: i, j, iter
real(dp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, &
scale, sumsq
logical(lk) :: up
complex(dp) :: zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not. ( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -1_${ik}$
else if ( n < 0_${ik}$ ) then
info = -2_${ik}$
else if ( lda < max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if ( info /= 0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEQUB', -info )
return
end if
up = stdlib_lsame( uplo, 'U' )
amax = zero
! quick return if possible.
if ( n == 0_${ik}$ ) then
scond = one
return
end if
do i = 1, n
s( i ) = zero
end do
amax = zero
if ( up ) then
do j = 1, n
do i = 1, j-1
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
end do
else
do j = 1, n
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
do i = j+1, n
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
end do
end if
do j = 1, n
s( j ) = one / s( j )
end do
tol = one / sqrt( two * n )
do iter = 1, max_iter
scale = zero
sumsq = zero
! beta = |a|s
do i = 1, n
work( i ) = zero
end do
if ( up ) then
do j = 1, n
do i = 1, j-1
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
end do
else
do j = 1, n
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
do i = j+1, n
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
end do
end if
! avg = s^t beta / n
avg = zero
do i = 1, n
avg = avg + real( s( i )*work( i ),KIND=dp)
end do
avg = avg / n
std = zero
do i = n+1, 2*n
work( i ) = s( i-n ) * work( i-n ) - avg
end do
call stdlib${ii}$_zlassq( n, work( n+1 ), 1_${ik}$, scale, sumsq )
std = scale * sqrt( sumsq / n )
if ( std < tol * avg ) goto 999
do i = 1, n
t = cabs1( a( i, i ) )
si = s( i )
c2 = ( n-1 ) * t
c1 = ( n-2 ) * ( real( work( i ),KIND=dp) - t*si )
c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=dp) * si - n*avg
d = c1*c1 - 4_${ik}$*c0*c2
if ( d <= 0_${ik}$ ) then
info = -1_${ik}$
return
end if
si = -2_${ik}$*c0 / ( c1 + sqrt( d ) )
d = si - s( i )
u = zero
if ( up ) then
do j = 1, i
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
else
do j = 1, i
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
end if
avg = avg + ( u + real( work( i ),KIND=dp) ) * d / n
s( i ) = si
end do
end do
999 continue
smlnum = stdlib${ii}$_dlamch( 'SAFEMIN' )
bignum = one / smlnum
smin = bignum
smax = zero
t = one / sqrt( avg )
base = stdlib${ii}$_dlamch( 'B' )
u = one / log( base )
do i = 1, n
s( i ) = base ** int( u * log( s( i ) * t ),KIND=${ik}$)
smin = min( smin, s( i ) )
smax = max( smax, s( i ) )
end do
scond = max( smin, smlnum ) / min( smax, bignum )
end subroutine stdlib${ii}$_zheequb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$heequb( uplo, n, a, lda, s, scond, amax, work, info )
!! ZHEEQUB: computes row and column scalings intended to equilibrate a
!! Hermitian matrix A (with respect to the Euclidean norm) and reduce
!! its condition number. The scale factors S are computed by the BIN
!! algorithm (see references) so that the scaled matrix B with elements
!! B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
!! the smallest possible condition number over all possible diagonal
!! scalings.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(out) :: amax, scond
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
real(${ck}$), intent(out) :: s(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: max_iter = 100_${ik}$
! Local Scalars
integer(${ik}$) :: i, j, iter
real(${ck}$) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, &
scale, sumsq
logical(lk) :: up
complex(${ck}$) :: zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if ( .not. ( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -1_${ik}$
else if ( n < 0_${ik}$ ) then
info = -2_${ik}$
else if ( lda < max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if ( info /= 0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEQUB', -info )
return
end if
up = stdlib_lsame( uplo, 'U' )
amax = zero
! quick return if possible.
if ( n == 0_${ik}$ ) then
scond = one
return
end if
do i = 1, n
s( i ) = zero
end do
amax = zero
if ( up ) then
do j = 1, n
do i = 1, j-1
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
end do
else
do j = 1, n
s( j ) = max( s( j ), cabs1( a( j, j ) ) )
amax = max( amax, cabs1( a( j, j ) ) )
do i = j+1, n
s( i ) = max( s( i ), cabs1( a( i, j ) ) )
s( j ) = max( s( j ), cabs1( a( i, j ) ) )
amax = max( amax, cabs1( a( i, j ) ) )
end do
end do
end if
do j = 1, n
s( j ) = one / s( j )
end do
tol = one / sqrt( two * n )
do iter = 1, max_iter
scale = zero
sumsq = zero
! beta = |a|s
do i = 1, n
work( i ) = zero
end do
if ( up ) then
do j = 1, n
do i = 1, j-1
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
end do
else
do j = 1, n
work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
do i = j+1, n
work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
end do
end do
end if
! avg = s^t beta / n
avg = zero
do i = 1, n
avg = avg + real( s( i )*work( i ),KIND=${ck}$)
end do
avg = avg / n
std = zero
do i = n+1, 2*n
work( i ) = s( i-n ) * work( i-n ) - avg
end do
call stdlib${ii}$_${ci}$lassq( n, work( n+1 ), 1_${ik}$, scale, sumsq )
std = scale * sqrt( sumsq / n )
if ( std < tol * avg ) goto 999
do i = 1, n
t = cabs1( a( i, i ) )
si = s( i )
c2 = ( n-1 ) * t
c1 = ( n-2 ) * ( real( work( i ),KIND=${ck}$) - t*si )
c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=${ck}$) * si - n*avg
d = c1*c1 - 4_${ik}$*c0*c2
if ( d <= 0_${ik}$ ) then
info = -1_${ik}$
return
end if
si = -2_${ik}$*c0 / ( c1 + sqrt( d ) )
d = si - s( i )
u = zero
if ( up ) then
do j = 1, i
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
else
do j = 1, i
t = cabs1( a( i, j ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
do j = i+1,n
t = cabs1( a( j, i ) )
u = u + s( j )*t
work( j ) = work( j ) + d*t
end do
end if
avg = avg + ( u + real( work( i ),KIND=${ck}$) ) * d / n
s( i ) = si
end do
end do
999 continue
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFEMIN' )
bignum = one / smlnum
smin = bignum
smax = zero
t = one / sqrt( avg )
base = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
u = one / log( base )
do i = 1, n
s( i ) = base ** int( u * log( s( i ) * t ),KIND=${ik}$)
smin = min( smin, s( i ) )
smax = max( smax, s( i ) )
end do
scond = max( smin, smlnum ) / min( smax, bignum )
end subroutine stdlib${ii}$_${ci}$heequb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info )
!! CHETRS2 solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by CHETRF and converted by CSYCONV.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, iinfo, j, k, kp
real(sp) :: s
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRS2', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! convert a
call stdlib${ii}$_csyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! p**t * b
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb &
)
k=k-2
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_ctrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (u \p**t * b) ]
i=n
do while ( i >= 1 )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
elseif ( i > 1_${ik}$) then
if ( ipiv(i-1) == ipiv(i) ) then
akm1k = work(i)
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
endif
endif
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_ctrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp,&
1_${ik}$ ), ldb )
k=k+2
endif
end do
else
! solve a*x = b, where a = l*d*l**h.
! p**t * b
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k+1).
kp = -ipiv( k+1 )
if( kp==-ipiv( k ) )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+2
endif
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_ctrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (l \p**t * b) ]
i=1_${ik}$
do while ( i <= n )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else
akm1k = work(i)
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
endif
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_ctrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, &
1_${ik}$ ), ldb )
k=k-2
endif
end do
end if
! revert a
call stdlib${ii}$_csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
return
end subroutine stdlib${ii}$_chetrs2
pure module subroutine stdlib${ii}$_zhetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info )
!! ZHETRS2 solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF and converted by ZSYCONV.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, iinfo, j, k, kp
real(dp) :: s
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS2', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! convert a
call stdlib${ii}$_zsyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! p**t * b
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb &
)
k=k-2
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_ztrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (u \p**t * b) ]
i=n
do while ( i >= 1 )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
elseif ( i > 1_${ik}$) then
if ( ipiv(i-1) == ipiv(i) ) then
akm1k = work(i)
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
endif
endif
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_ztrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp,&
1_${ik}$ ), ldb )
k=k+2
endif
end do
else
! solve a*x = b, where a = l*d*l**h.
! p**t * b
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k+1).
kp = -ipiv( k+1 )
if( kp==-ipiv( k ) )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+2
endif
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_ztrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (l \p**t * b) ]
i=1_${ik}$
do while ( i <= n )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else
akm1k = work(i)
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
endif
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_ztrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, &
1_${ik}$ ), ldb )
k=k-2
endif
end do
end if
! revert a
call stdlib${ii}$_zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
return
end subroutine stdlib${ii}$_zhetrs2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info )
!! ZHETRS2: solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHETRF and converted by ZSYCONV.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, iinfo, j, k, kp
real(${ck}$) :: s
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS2', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
! convert a
call stdlib${ii}$_${ci}$syconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! p**t * b
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb &
)
k=k-2
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (u \p**t * b) ]
i=n
do while ( i >= 1 )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
elseif ( i > 1_${ik}$) then
if ( ipiv(i-1) == ipiv(i) ) then
akm1k = work(i)
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
endif
endif
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp,&
1_${ik}$ ), ldb )
k=k+2
endif
end do
else
! solve a*x = b, where a = l*d*l**h.
! p**t * b
k=1_${ik}$
do while ( k <= n )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+1
else
! 2 x 2 diagonal block
! interchange rows k and -ipiv(k+1).
kp = -ipiv( k+1 )
if( kp==-ipiv( k ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k+2
endif
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_${ci}$trsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb)
! compute d \ b -> b [ d \ (l \p**t * b) ]
i=1_${ik}$
do while ( i <= n )
if( ipiv(i) > 0_${ik}$ ) then
s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else
akm1k = work(i)
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
endif
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb)
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
k=n
do while ( k >= 1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k=k-1
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, &
1_${ik}$ ), ldb )
k=k-2
endif
end do
end if
! revert a
call stdlib${ii}$_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
return
end subroutine stdlib${ii}$_${ci}$hetrs2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info )
!! CHETRS_3 solves a system of linear equations A * X = B with a complex
!! Hermitian matrix A using the factorization computed
!! by CHETRF_RK or CHETRF_BK:
!! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!! 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.
!! This algorithm is using Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*), e(*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j, k, kp
real(sp) :: s
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRS_3', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! begin upper
! solve a*x = b, where a = u*d*u**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (u \p**t * b) ]
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if ( i>1_${ik}$ ) then
akm1k = e( i )
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
else
! begin lower
! solve a*x = b, where a = l*d*l**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (l \p**t * b) ]
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if( i<n ) then
akm1k = e( i )
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_ctrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! end lower
end if
return
end subroutine stdlib${ii}$_chetrs_3
pure module subroutine stdlib${ii}$_zhetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info )
!! ZHETRS_3 solves a system of linear equations A * X = B with a complex
!! Hermitian matrix A using the factorization computed
!! by ZHETRF_RK or ZHETRF_BK:
!! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!! 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.
!! This algorithm is using Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*), e(*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j, k, kp
real(dp) :: s
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS_3', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! begin upper
! solve a*x = b, where a = u*d*u**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (u \p**t * b) ]
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if ( i>1_${ik}$ ) then
akm1k = e( i )
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
else
! begin lower
! solve a*x = b, where a = l*d*l**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (l \p**t * b) ]
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if( i<n ) then
akm1k = e( i )
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_ztrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! end lower
end if
return
end subroutine stdlib${ii}$_zhetrs_3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info )
!! ZHETRS_3: solves a system of linear equations A * X = B with a complex
!! Hermitian matrix A using the factorization computed
!! by ZHETRF_RK or ZHETRF_BK:
!! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
!! 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.
!! This algorithm is using Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, n, nrhs
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*), e(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j, k, kp
real(${ck}$) :: s
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRS_3', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! begin upper
! solve a*x = b, where a = u*d*u**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (u \p**t * b) -> b [ (u \p**t * b) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (u \p**t * b) ]
i = n
do while ( i>=1 )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if ( i>1_${ik}$ ) then
akm1k = e( i )
akm1 = a( i-1, i-1 ) / akm1k
ak = a( i, i ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i-1, j ) / akm1k
bk = b( i, j ) / conjg( akm1k )
b( i-1, j ) = ( ak*bkm1-bk ) / denom
b( i, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i - 1_${ik}$
end if
i = i - 1_${ik}$
end do
! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for upper case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
else
! begin lower
! solve a*x = b, where a = l*d*l**h.
! p**t * b
! interchange rows k and ipiv(k) of matrix b in the same order
! that the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with increment 1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = 1, n, 1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! compute (l \p**t * b) -> b [ (l \p**t * b) ]
call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb )
! compute d \ b -> b [ d \ (l \p**t * b) ]
i = 1_${ik}$
do while ( i<=n )
if( ipiv( i )>0_${ik}$ ) then
s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb )
else if( i<n ) then
akm1k = e( i )
akm1 = a( i, i ) / conjg( akm1k )
ak = a( i+1, i+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( i, j ) / conjg( akm1k )
bk = b( i+1, j ) / akm1k
b( i, j ) = ( ak*bkm1-bk ) / denom
b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
i = i + 1_${ik}$
end if
i = i + 1_${ik}$
end do
! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ]
call stdlib${ii}$_${ci}$trsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb )
! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ]
! interchange rows k and ipiv(k) of matrix b in reverse order
! from the formation order of ipiv(i) vector for lower case.
! (we can do the simple loop over ipiv with decrement -1,
! since the abs value of ipiv(i) represents the row index
! of the interchange with row i in both 1x1 and 2x2 pivot cases)
do k = n, 1, -1
kp = abs( ipiv( k ) )
if( kp/=k ) then
call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
end if
end do
! end lower
end if
return
end subroutine stdlib${ii}$_${ci}$hetrs_3
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cheswapr( uplo, n, a, lda, i1, i2)
!! CHESWAPR applies an elementary permutation on the rows and the columns of
!! a hermitian matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: i1, i2, lda, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,n)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(sp) :: tmp
! Executable Statements
upper = stdlib_lsame( uplo, 'U' )
if (upper) then
! upper
! first swap
! - swap column i1 and i2 from i1 to i1-1
call stdlib${ii}$_cswap( i1-1, a(1_${ik}$,i1), 1_${ik}$, a(1_${ik}$,i2), 1_${ik}$ )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap row i1 from i1+1 to i2-1 with col i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1,i1+i)
a(i1,i1+i)=conjg(a(i1+i,i2))
a(i1+i,i2)=conjg(tmp)
end do
a(i1,i2)=conjg(a(i1,i2))
! third swap
! - swap row i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i1,i)
a(i1,i)=a(i2,i)
a(i2,i)=tmp
end do
else
! lower
! first swap
! - swap row i1 and i2 from 1 to i1-1
call stdlib${ii}$_cswap ( i1-1, a(i1,1_${ik}$), lda, a(i2,1_${ik}$), lda )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap col i1 from i1+1 to i2-1 with row i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1+i,i1)
a(i1+i,i1)=conjg(a(i2,i1+i))
a(i2,i1+i)=conjg(tmp)
end do
a(i2,i1)=conjg(a(i2,i1))
! third swap
! - swap col i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i,i1)
a(i,i1)=a(i,i2)
a(i,i2)=tmp
end do
endif
end subroutine stdlib${ii}$_cheswapr
pure module subroutine stdlib${ii}$_zheswapr( uplo, n, a, lda, i1, i2)
!! ZHESWAPR applies an elementary permutation on the rows and the columns of
!! a hermitian matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: i1, i2, lda, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,n)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(dp) :: tmp
! Executable Statements
upper = stdlib_lsame( uplo, 'U' )
if (upper) then
! upper
! first swap
! - swap column i1 and i2 from i1 to i1-1
call stdlib${ii}$_zswap( i1-1, a(1_${ik}$,i1), 1_${ik}$, a(1_${ik}$,i2), 1_${ik}$ )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap row i1 from i1+1 to i2-1 with col i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1,i1+i)
a(i1,i1+i)=conjg(a(i1+i,i2))
a(i1+i,i2)=conjg(tmp)
end do
a(i1,i2)=conjg(a(i1,i2))
! third swap
! - swap row i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i1,i)
a(i1,i)=a(i2,i)
a(i2,i)=tmp
end do
else
! lower
! first swap
! - swap row i1 and i2 from 1 to i1-1
call stdlib${ii}$_zswap ( i1-1, a(i1,1_${ik}$), lda, a(i2,1_${ik}$), lda )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap col i1 from i1+1 to i2-1 with row i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1+i,i1)
a(i1+i,i1)=conjg(a(i2,i1+i))
a(i2,i1+i)=conjg(tmp)
end do
a(i2,i1)=conjg(a(i2,i1))
! third swap
! - swap col i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i,i1)
a(i,i1)=a(i,i2)
a(i,i2)=tmp
end do
endif
end subroutine stdlib${ii}$_zheswapr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$heswapr( uplo, n, a, lda, i1, i2)
!! ZHESWAPR: applies an elementary permutation on the rows and the columns of
!! a hermitian matrix.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: i1, i2, lda, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,n)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(${ck}$) :: tmp
! Executable Statements
upper = stdlib_lsame( uplo, 'U' )
if (upper) then
! upper
! first swap
! - swap column i1 and i2 from i1 to i1-1
call stdlib${ii}$_${ci}$swap( i1-1, a(1_${ik}$,i1), 1_${ik}$, a(1_${ik}$,i2), 1_${ik}$ )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap row i1 from i1+1 to i2-1 with col i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1,i1+i)
a(i1,i1+i)=conjg(a(i1+i,i2))
a(i1+i,i2)=conjg(tmp)
end do
a(i1,i2)=conjg(a(i1,i2))
! third swap
! - swap row i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i1,i)
a(i1,i)=a(i2,i)
a(i2,i)=tmp
end do
else
! lower
! first swap
! - swap row i1 and i2 from 1 to i1-1
call stdlib${ii}$_${ci}$swap ( i1-1, a(i1,1_${ik}$), lda, a(i2,1_${ik}$), lda )
! second swap :
! - swap a(i1,i1) and a(i2,i2)
! - swap col i1 from i1+1 to i2-1 with row i2 from i1+1 to i2-1
! - swap a(i2,i1) and a(i1,i2)
tmp=a(i1,i1)
a(i1,i1)=a(i2,i2)
a(i2,i2)=tmp
do i=1,i2-i1-1
tmp=a(i1+i,i1)
a(i1+i,i1)=conjg(a(i2,i1+i))
a(i2,i1+i)=conjg(tmp)
end do
a(i2,i1)=conjg(a(i2,i1))
! third swap
! - swap col i1 and i2 from i2+1 to n
do i=i2+1,n
tmp=a(i,i1)
a(i,i1)=a(i,i2)
a(i,i2)=tmp
end do
endif
end subroutine stdlib${ii}$_${ci}$heswapr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chpcon( uplo, n, ap, ipiv, anorm, rcond, work, info )
!! CHPCON estimates the reciprocal of the condition number of a complex
!! Hermitian packed matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by CHPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: ap(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ip, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
ip = n*( n+1 ) / 2_${ik}$
do i = n, 1, -1
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip - i
end do
else
! lower triangular storage: examine d from top to bottom.
ip = 1_${ik}$
do i = 1, n
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip + n - i + 1_${ik}$
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_chptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_chpcon
pure module subroutine stdlib${ii}$_zhpcon( uplo, n, ap, ipiv, anorm, rcond, work, info )
!! ZHPCON estimates the reciprocal of the condition number of a complex
!! Hermitian packed matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: ap(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ip, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
ip = n*( n+1 ) / 2_${ik}$
do i = n, 1, -1
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip - i
end do
else
! lower triangular storage: examine d from top to bottom.
ip = 1_${ik}$
do i = 1, n
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip + n - i + 1_${ik}$
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_zhptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zhpcon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hpcon( uplo, n, ap, ipiv, anorm, rcond, work, info )
!! ZHPCON: estimates the reciprocal of the condition number of a complex
!! Hermitian packed matrix A using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHPTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, ip, kase
real(${ck}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( anorm<zero ) then
info = -5_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPCON', -info )
return
end if
! quick return if possible
rcond = zero
if( n==0_${ik}$ ) then
rcond = one
return
else if( anorm<=zero ) then
return
end if
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
ip = n*( n+1 ) / 2_${ik}$
do i = n, 1, -1
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip - i
end do
else
! lower triangular storage: examine d from top to bottom.
ip = 1_${ik}$
do i = 1, n
if( ipiv( i )>0 .and. ap( ip )==zero )return
ip = ip + n - i + 1_${ik}$
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**h) or inv(u*d*u**h).
call stdlib${ii}$_${ci}$hptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$hpcon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chptrf( uplo, n, ap, ipiv, info )
!! CHPTRF computes the factorization of a complex Hermitian packed
!! matrix A using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! 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.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp
real(sp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(sp) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPTRF', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
kc = ( n-1 )*n / 2_${ik}$ + 1_${ik}$
10 continue
knc = kc
! if k < 1, exit from loop
if( k<1 )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc+k-1 ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_icamax( k-1, ap( kc ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-1 ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
jmax = imax
kx = imax*( imax+1 ) / 2_${ik}$ + imax
do j = imax + 1, k
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + j
end do
kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_icamax( imax-1, ap( kpc ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc+imax-1 ),KIND=sp) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k - kstep + 1_${ik}$
if( kstep==2_${ik}$ )knc = knc - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_cswap( kp-1, ap( knc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, kk - 1
kx = kx + j - 1_${ik}$
t = conjg( ap( knc+j-1 ) )
ap( knc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( kx+kk-1 ) = conjg( ap( kx+kk-1 ) )
r1 = real( ap( knc+kk-1 ),KIND=sp)
ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=sp)
ap( kpc+kp-1 ) = r1
if( kstep==2_${ik}$ ) then
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp)
t = ap( kc+k-2 )
ap( kc+k-2 ) = ap( kc+kp-1 )
ap( kc+kp-1 ) = t
end if
else
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp)
if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=sp)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( ap( kc+k-1 ),KIND=sp)
call stdlib${ii}$_chpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap )
! store u(k) in column k
call stdlib${ii}$_csscal( k-1, r1, ap( kc ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_slapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=sp),aimag( ap( k-1+( &
k-1 )*k / 2_${ik}$ ) ) )
d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=sp) / d
d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=sp) / d
tt = one / ( d11*d22-one )
d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k &
/ 2_${ik}$ ) )
wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) )
do i = j, 1, -1
ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )&
*conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 )
end do
ap( j+( k-1 )*k / 2_${ik}$ ) = wk
ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1
ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=sp), &
zero,KIND=sp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
kc = knc - k
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
kc = 1_${ik}$
npp = n*( n+1 ) / 2_${ik}$
60 continue
knc = kc
! if k > n, exit from loop
if( k>n )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc ),KIND=sp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k<n ) then
imax = k + stdlib${ii}$_icamax( n-k, ap( kc+1 ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc ) = real( ap( kc ),KIND=sp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
kx = kc + imax - k
do j = k, imax - 1
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + n - j
end do
kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2_${ik}$ + 1_${ik}$
if( imax<n ) then
jmax = imax + stdlib${ii}$_icamax( n-imax, ap( kpc+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc ),KIND=sp) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k + kstep - 1_${ik}$
if( kstep==2_${ik}$ )knc = knc + n - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_cswap( n-kp, ap( knc+kp-kk+1 ), 1_${ik}$, ap( kpc+1 ),1_${ik}$ )
kx = knc + kp - kk
do j = kk + 1, kp - 1
kx = kx + n - j + 1_${ik}$
t = conjg( ap( knc+j-kk ) )
ap( knc+j-kk ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( knc+kp-kk ) = conjg( ap( knc+kp-kk ) )
r1 = real( ap( knc ),KIND=sp)
ap( knc ) = real( ap( kpc ),KIND=sp)
ap( kpc ) = r1
if( kstep==2_${ik}$ ) then
ap( kc ) = real( ap( kc ),KIND=sp)
t = ap( kc+1 )
ap( kc+1 ) = ap( kc+kp-k )
ap( kc+kp-k ) = t
end if
else
ap( kc ) = real( ap( kc ),KIND=sp)
if( kstep==2_${ik}$ )ap( knc ) = real( ap( knc ),KIND=sp)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( ap( kc ),KIND=sp)
call stdlib${ii}$_chpr( uplo, n-k, -r1, ap( kc+1 ), 1_${ik}$,ap( kc+n-k+1 ) )
! store l(k) in column k
call stdlib${ii}$_csscal( n-k, r1, ap( kc+1 ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_slapy2( real( ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=sp),aimag( &
ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) ) )
d11 = real( ap( k+1+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ),KIND=sp) / d
d22 = real( ap( k+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=sp) / d
tt = one / ( d11*d22-one )
d21 = ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ )-d21*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
)
wkp1 = d*( d22*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )-conjg( d21 )*ap( j+( k-1 )*( &
2_${ik}$*n-k ) / 2_${ik}$ ) )
do i = j, n
ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) = ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) - ap( &
i+( k-1 )*( 2_${ik}$*n-k ) /2_${ik}$ )*conjg( wk ) - ap( i+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
*conjg( wkp1 )
end do
ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) = wk
ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ) = wkp1
ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ )= cmplx( real( ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ &
),KIND=sp),zero,KIND=sp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
kc = knc + n - k + 2_${ik}$
go to 60
end if
110 continue
return
end subroutine stdlib${ii}$_chptrf
pure module subroutine stdlib${ii}$_zhptrf( uplo, n, ap, ipiv, info )
!! ZHPTRF computes the factorization of a complex Hermitian packed
!! matrix A using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! 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.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp
real(dp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(dp) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRF', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
kc = ( n-1 )*n / 2_${ik}$ + 1_${ik}$
10 continue
knc = kc
! if k < 1, exit from loop
if( k<1 )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc+k-1 ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_izamax( k-1, ap( kc ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-1 ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
jmax = imax
kx = imax*( imax+1 ) / 2_${ik}$ + imax
do j = imax + 1, k
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + j
end do
kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_izamax( imax-1, ap( kpc ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc+imax-1 ),KIND=dp) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k - kstep + 1_${ik}$
if( kstep==2_${ik}$ )knc = knc - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_zswap( kp-1, ap( knc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, kk - 1
kx = kx + j - 1_${ik}$
t = conjg( ap( knc+j-1 ) )
ap( knc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( kx+kk-1 ) = conjg( ap( kx+kk-1 ) )
r1 = real( ap( knc+kk-1 ),KIND=dp)
ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=dp)
ap( kpc+kp-1 ) = r1
if( kstep==2_${ik}$ ) then
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp)
t = ap( kc+k-2 )
ap( kc+k-2 ) = ap( kc+kp-1 )
ap( kc+kp-1 ) = t
end if
else
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp)
if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=dp)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( ap( kc+k-1 ),KIND=dp)
call stdlib${ii}$_zhpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap )
! store u(k) in column k
call stdlib${ii}$_zdscal( k-1, r1, ap( kc ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_dlapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=dp),aimag( ap( k-1+( &
k-1 )*k / 2_${ik}$ ) ) )
d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=dp) / d
d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=dp) / d
tt = one / ( d11*d22-one )
d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k &
/ 2_${ik}$ ) )
wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) )
do i = j, 1, -1
ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )&
*conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 )
end do
ap( j+( k-1 )*k / 2_${ik}$ ) = wk
ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1
ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=dp), &
zero,KIND=dp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
kc = knc - k
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
kc = 1_${ik}$
npp = n*( n+1 ) / 2_${ik}$
60 continue
knc = kc
! if k > n, exit from loop
if( k>n )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc ),KIND=dp) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k<n ) then
imax = k + stdlib${ii}$_izamax( n-k, ap( kc+1 ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc ) = real( ap( kc ),KIND=dp)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
kx = kc + imax - k
do j = k, imax - 1
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + n - j
end do
kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2_${ik}$ + 1_${ik}$
if( imax<n ) then
jmax = imax + stdlib${ii}$_izamax( n-imax, ap( kpc+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc ),KIND=dp) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k + kstep - 1_${ik}$
if( kstep==2_${ik}$ )knc = knc + n - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_zswap( n-kp, ap( knc+kp-kk+1 ), 1_${ik}$, ap( kpc+1 ),1_${ik}$ )
kx = knc + kp - kk
do j = kk + 1, kp - 1
kx = kx + n - j + 1_${ik}$
t = conjg( ap( knc+j-kk ) )
ap( knc+j-kk ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( knc+kp-kk ) = conjg( ap( knc+kp-kk ) )
r1 = real( ap( knc ),KIND=dp)
ap( knc ) = real( ap( kpc ),KIND=dp)
ap( kpc ) = r1
if( kstep==2_${ik}$ ) then
ap( kc ) = real( ap( kc ),KIND=dp)
t = ap( kc+1 )
ap( kc+1 ) = ap( kc+kp-k )
ap( kc+kp-k ) = t
end if
else
ap( kc ) = real( ap( kc ),KIND=dp)
if( kstep==2_${ik}$ )ap( knc ) = real( ap( knc ),KIND=dp)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( ap( kc ),KIND=dp)
call stdlib${ii}$_zhpr( uplo, n-k, -r1, ap( kc+1 ), 1_${ik}$,ap( kc+n-k+1 ) )
! store l(k) in column k
call stdlib${ii}$_zdscal( n-k, r1, ap( kc+1 ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_dlapy2( real( ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=dp),aimag( &
ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) ) )
d11 = real( ap( k+1+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ),KIND=dp) / d
d22 = real( ap( k+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=dp) / d
tt = one / ( d11*d22-one )
d21 = ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ )-d21*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
)
wkp1 = d*( d22*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )-conjg( d21 )*ap( j+( k-1 )*( &
2_${ik}$*n-k ) /2_${ik}$ ) )
do i = j, n
ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) = ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) - ap( &
i+( k-1 )*( 2_${ik}$*n-k ) /2_${ik}$ )*conjg( wk ) - ap( i+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
*conjg( wkp1 )
end do
ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) = wk
ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ) = wkp1
ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ )= cmplx( real( ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ &
),KIND=dp),zero,KIND=dp)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
kc = knc + n - k + 2_${ik}$
go to 60
end if
110 continue
return
end subroutine stdlib${ii}$_zhptrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hptrf( uplo, n, ap, ipiv, info )
!! ZHPTRF: computes the factorization of a complex Hermitian packed
!! matrix A using the Bunch-Kaufman diagonal pivoting method:
!! A = U*D*U**H or A = L*D*L**H
!! 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.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: ap(*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp
real(${ck}$) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt
complex(${ck}$) :: d12, d21, t, wk, wkm1, wkp1, zdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) )
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRF', -info )
return
end if
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( upper ) then
! factorize a as u*d*u**h using the upper triangle of a
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2
k = n
kc = ( n-1 )*n / 2_${ik}$ + 1_${ik}$
10 continue
knc = kc
! if k < 1, exit from loop
if( k<1 )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc+k-1 ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k>1_${ik}$ ) then
imax = stdlib${ii}$_i${ci}$amax( k-1, ap( kc ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-1 ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
jmax = imax
kx = imax*( imax+1 ) / 2_${ik}$ + imax
do j = imax + 1, k
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + j
end do
kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$
if( imax>1_${ik}$ ) then
jmax = stdlib${ii}$_i${ci}$amax( imax-1, ap( kpc ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc+imax-1 ),KIND=${ck}$) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k - kstep + 1_${ik}$
if( kstep==2_${ik}$ )knc = knc - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the leading
! submatrix a(1:k,1:k)
call stdlib${ii}$_${ci}$swap( kp-1, ap( knc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, kk - 1
kx = kx + j - 1_${ik}$
t = conjg( ap( knc+j-1 ) )
ap( knc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( kx+kk-1 ) = conjg( ap( kx+kk-1 ) )
r1 = real( ap( knc+kk-1 ),KIND=${ck}$)
ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=${ck}$)
ap( kpc+kp-1 ) = r1
if( kstep==2_${ik}$ ) then
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$)
t = ap( kc+k-2 )
ap( kc+k-2 ) = ap( kc+kp-1 )
ap( kc+kp-1 ) = t
end if
else
ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$)
if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=${ck}$)
end if
! update the leading submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = u(k)*d(k)
! where u(k) is the k-th column of u
! perform a rank-1 update of a(1:k-1,1:k-1) as
! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h
r1 = one / real( ap( kc+k-1 ),KIND=${ck}$)
call stdlib${ii}$_${ci}$hpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap )
! store u(k) in column k
call stdlib${ii}$_${ci}$dscal( k-1, r1, ap( kc ), 1_${ik}$ )
else
! 2-by-2 pivot block d(k): columns k and k-1 now hold
! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k)
! where u(k) and u(k-1) are the k-th and (k-1)-th columns
! of u
! perform a rank-2 update of a(1:k-2,1:k-2) as
! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h
! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h
if( k>2_${ik}$ ) then
d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=${ck}$),aimag( ap( k-1+( &
k-1 )*k / 2_${ik}$ ) ) )
d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=${ck}$) / d
d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=${ck}$) / d
tt = one / ( d11*d22-one )
d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d
d = tt / d
do j = k - 2, 1, -1
wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k &
/ 2_${ik}$ ) )
wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) )
do i = j, 1, -1
ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )&
*conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 )
end do
ap( j+( k-1 )*k / 2_${ik}$ ) = wk
ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1
ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=${ck}$), &
zero,KIND=${ck}$)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k-1 ) = -kp
end if
! decrease k and return to the start of the main loop
k = k - kstep
kc = knc - k
go to 10
else
! factorize a as l*d*l**h using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2
k = 1_${ik}$
kc = 1_${ik}$
npp = n*( n+1 ) / 2_${ik}$
60 continue
knc = kc
! if k > n, exit from loop
if( k>n )go to 110
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( real( ap( kc ),KIND=${ck}$) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value
if( k<n ) then
imax = k + stdlib${ii}$_i${ci}$amax( n-k, ap( kc+1 ), 1_${ik}$ )
colmax = cabs1( ap( kc+imax-k ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero: set info and continue
if( info==0_${ik}$ )info = k
kp = k
ap( kc ) = real( ap( kc ),KIND=${ck}$)
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
rowmax = zero
kx = kc + imax - k
do j = k, imax - 1
if( cabs1( ap( kx ) )>rowmax ) then
rowmax = cabs1( ap( kx ) )
jmax = j
end if
kx = kx + n - j
end do
kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2_${ik}$ + 1_${ik}$
if( imax<n ) then
jmax = imax + stdlib${ii}$_i${ci}$amax( n-imax, ap( kpc+1 ), 1_${ik}$ )
rowmax = max( rowmax, cabs1( ap( kpc+jmax-imax ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( real( ap( kpc ),KIND=${ck}$) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
kk = k + kstep - 1_${ik}$
if( kstep==2_${ik}$ )knc = knc + n - k + 1_${ik}$
if( kp/=kk ) then
! interchange rows and columns kk and kp in the trailing
! submatrix a(k:n,k:n)
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, ap( knc+kp-kk+1 ), 1_${ik}$, ap( kpc+1 ),1_${ik}$ )
kx = knc + kp - kk
do j = kk + 1, kp - 1
kx = kx + n - j + 1_${ik}$
t = conjg( ap( knc+j-kk ) )
ap( knc+j-kk ) = conjg( ap( kx ) )
ap( kx ) = t
end do
ap( knc+kp-kk ) = conjg( ap( knc+kp-kk ) )
r1 = real( ap( knc ),KIND=${ck}$)
ap( knc ) = real( ap( kpc ),KIND=${ck}$)
ap( kpc ) = r1
if( kstep==2_${ik}$ ) then
ap( kc ) = real( ap( kc ),KIND=${ck}$)
t = ap( kc+1 )
ap( kc+1 ) = ap( kc+kp-k )
ap( kc+kp-k ) = t
end if
else
ap( kc ) = real( ap( kc ),KIND=${ck}$)
if( kstep==2_${ik}$ )ap( knc ) = real( ap( knc ),KIND=${ck}$)
end if
! update the trailing submatrix
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k now holds
! w(k) = l(k)*d(k)
! where l(k) is the k-th column of l
if( k<n ) then
! perform a rank-1 update of a(k+1:n,k+1:n) as
! a := a - l(k)*d(k)*l(k)**h = a - w(k)*(1/d(k))*w(k)**h
r1 = one / real( ap( kc ),KIND=${ck}$)
call stdlib${ii}$_${ci}$hpr( uplo, n-k, -r1, ap( kc+1 ), 1_${ik}$,ap( kc+n-k+1 ) )
! store l(k) in column k
call stdlib${ii}$_${ci}$dscal( n-k, r1, ap( kc+1 ), 1_${ik}$ )
end if
else
! 2-by-2 pivot block d(k): columns k and k+1 now hold
! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k)
! where l(k) and l(k+1) are the k-th and (k+1)-th columns
! of l
if( k<n-1 ) then
! perform a rank-2 update of a(k+2:n,k+2:n) as
! a := a - ( l(k) l(k+1) )*d(k)*( l(k) l(k+1) )**h
! = a - ( w(k) w(k+1) )*inv(d(k))*( w(k) w(k+1) )**h
! where l(k) and l(k+1) are the k-th and (k+1)-th
! columns of l
d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=${ck}$),aimag( &
ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) ) )
d11 = real( ap( k+1+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ),KIND=${ck}$) / d
d22 = real( ap( k+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ),KIND=${ck}$) / d
tt = one / ( d11*d22-one )
d21 = ap( k+1+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) / d
d = tt / d
do j = k + 2, n
wk = d*( d11*ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ )-d21*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
)
wkp1 = d*( d22*ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )-conjg( d21 )*ap( j+( k-1 )*( &
2_${ik}$*n-k ) /2_${ik}$ ) )
do i = j, n
ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) = ap( i+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ ) - ap( &
i+( k-1 )*( 2_${ik}$*n-k ) /2_${ik}$ )*conjg( wk ) - ap( i+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ )&
*conjg( wkp1 )
end do
ap( j+( k-1 )*( 2_${ik}$*n-k ) / 2_${ik}$ ) = wk
ap( j+k*( 2_${ik}$*n-k-1 ) / 2_${ik}$ ) = wkp1
ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ )= cmplx( real( ap( j+( j-1 )*( 2_${ik}$*n-j ) / 2_${ik}$ &
),KIND=${ck}$),zero,KIND=${ck}$)
end do
end if
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) then
ipiv( k ) = kp
else
ipiv( k ) = -kp
ipiv( k+1 ) = -kp
end if
! increase k and return to the start of the main loop
k = k + kstep
kc = knc + n - k + 2_${ik}$
go to 60
end if
110 continue
return
end subroutine stdlib${ii}$_${ci}$hptrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! CHPTRS solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A stored in packed format using the factorization
!! A = U*D*U**H or A = L*D*L**H computed by CHPTRF.
! -- lapack computational routine --
! -- lapack 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(in) :: ipiv(*)
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(sp) :: s
complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_cgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=sp) / real( ap( kc+k-1 ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),&
1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_cgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=sp) / real( ap( kc ),KIND=sp)
call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_cgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / conjg( akm1k )
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc-( n-k ) ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_clacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_chptrs
pure module subroutine stdlib${ii}$_zhptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZHPTRS solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A stored in packed format using the factorization
!! A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
! -- lapack computational routine --
! -- lapack 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(in) :: ipiv(*)
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(dp) :: s
complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_zgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=dp) / real( ap( kc+k-1 ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),&
1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_zgeru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=dp) / real( ap( kc ),KIND=dp)
call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_zgeru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / conjg( akm1k )
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc-( n-k ) ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_zlacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_zhptrs
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info )
!! ZHPTRS: solves a system of linear equations A*X = B with a complex
!! Hermitian matrix A stored in packed format using the factorization
!! A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
! -- lapack computational routine --
! -- lapack 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(in) :: ipiv(*)
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: b(ldb,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kp
real(${ck}$) :: s
complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( nrhs<0_${ik}$ ) then
info = -3_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRS', -info )
return
end if
! quick return if possible
if( n==0 .or. nrhs==0 )return
if( upper ) then
! solve a*x = b, where a = u*d*u**h.
! first solve u*d*x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
10 continue
! if k < 1, exit from loop.
if( k<1 )go to 30
kc = kc - k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in column k of a.
call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=${ck}$) / real( ap( kc+k-1 ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k-1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(u(k)), where u(k) is the transformation
! stored in columns k-1 and k of a.
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, &
1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+k-2 )
akm1 = ap( kc-1 ) / akm1k
ak = ap( kc+k-1 ) / conjg( akm1k )
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k-1, j ) / akm1k
bk = b( k, j ) / conjg( akm1k )
b( k-1, j ) = ( ak*bkm1-bk ) / denom
b( k, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc - k + 1_${ik}$
k = k - 2_${ik}$
end if
go to 10
30 continue
! next solve u**h *x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
40 continue
! if k > n, exit from loop.
if( k>n )go to 50
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(u**h(k)), where u(k) is the transformation
! stored in column k of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + k
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(u**h(k+1)), where u(k+1) is the transformation
! stored in columns k and k+1 of a.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), &
1_${ik}$, cone, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),&
1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc + 2_${ik}$*k + 1_${ik}$
k = k + 2_${ik}$
end if
go to 40
50 continue
else
! solve a*x = b, where a = l*d*l**h.
! first solve l*d*x = b, overwriting b with x.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
60 continue
! if k > n, exit from loop.
if( k>n )go to 80
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n )call stdlib${ii}$_${ci}$geru( n-k, nrhs, -cone, ap( kc+1 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+&
1_${ik}$, 1_${ik}$ ), ldb )
! multiply by the inverse of the diagonal block.
s = real( cone,KIND=${ck}$) / real( ap( kc ),KIND=${ck}$)
call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb )
kc = kc + n - k + 1_${ik}$
k = k + 1_${ik}$
else
! 2 x 2 diagonal block
! interchange rows k+1 and -ipiv(k).
kp = -ipiv( k )
if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
! multiply by inv(l(k)), where l(k) is the transformation
! stored in columns k and k+1 of a.
if( k<n-1 ) then
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+2 ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( k+2, &
1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$geru( n-k-1, nrhs, -cone, ap( kc+n-k+2 ), 1_${ik}$,b( k+1, 1_${ik}$ ), ldb, b( &
k+2, 1_${ik}$ ), ldb )
end if
! multiply by the inverse of the diagonal block.
akm1k = ap( kc+1 )
akm1 = ap( kc ) / conjg( akm1k )
ak = ap( kc+n-k+1 ) / akm1k
denom = akm1*ak - cone
do j = 1, nrhs
bkm1 = b( k, j ) / conjg( akm1k )
bk = b( k+1, j ) / akm1k
b( k, j ) = ( ak*bkm1-bk ) / denom
b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
end do
kc = kc + 2_${ik}$*( n-k ) + 1_${ik}$
k = k + 2_${ik}$
end if
go to 60
80 continue
! next solve l**h *x = b, overwriting b with x.
! k is the main loop index, decreasing from n to 1 in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = n
kc = n*( n+1 ) / 2_${ik}$ + 1_${ik}$
90 continue
! if k < 1, exit from loop.
if( k<1 )go to 100
kc = kc - ( n-k+1 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! multiply by inv(l**h(k)), where l(k) is the transformation
! stored in column k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
end if
! interchange rows k and ipiv(k).
kp = ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
k = k - 1_${ik}$
else
! 2 x 2 diagonal block
! multiply by inv(l**h(k-1)), where l(k-1) is the transformation
! stored in columns k-1 and k of a.
if( k<n ) then
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc+1 ), 1_${ik}$, cone,b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k, nrhs, -cone,b( k+1, 1_${ik}$ ), ldb, &
ap( kc-( n-k ) ), 1_${ik}$, cone,b( k-1, 1_${ik}$ ), ldb )
call stdlib${ii}$_${ci}$lacgv( nrhs, b( k-1, 1_${ik}$ ), ldb )
end if
! interchange rows k and -ipiv(k).
kp = -ipiv( k )
if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb )
kc = kc - ( n-k+2 )
k = k - 2_${ik}$
end if
go to 90
100 continue
end if
return
end subroutine stdlib${ii}$_${ci}$hptrs
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chptri( uplo, n, ap, ipiv, work, info )
!! CHPTRI computes the inverse of a complex Hermitian indefinite matrix
!! A in packed storage using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by CHPTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(sp) :: ak, akp1, d, t
complex(sp) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=sp)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=sp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = real( ap( kc+k-1 ),KIND=sp) / t
akp1 = real( ap( kcnext+k ),KIND=sp) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=sp)
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_cdotc( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_ccopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kcnext &
),1_${ik}$ ),KIND=sp)
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_cswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = conjg( ap( kc+j-1 ) )
ap( kc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-1 ) = conjg( ap( kc+kp-1 ) )
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / real( ap( kc ),KIND=sp)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=sp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = real( ap( kcnext ),KIND=sp) / t
akp1 = real( ap( kc ),KIND=sp) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_ccopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=sp)
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_cdotc( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_ccopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -real( stdlib${ii}$_cdotc( n-k, work, 1_${ik}$, ap( kcnext+2 ),&
1_${ik}$ ),KIND=sp)
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_cswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = conjg( ap( kc+j-k ) )
ap( kc+j-k ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-k ) = conjg( ap( kc+kp-k ) )
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_chptri
pure module subroutine stdlib${ii}$_zhptri( uplo, n, ap, ipiv, work, info )
!! ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
!! A in packed storage using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHPTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(dp) :: ak, akp1, d, t
complex(dp) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=dp)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=dp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = real( ap( kc+k-1 ),KIND=dp) / t
akp1 = real( ap( kcnext+k ),KIND=dp) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=dp)
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_zdotc( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_zcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kcnext &
),1_${ik}$ ),KIND=dp)
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_zswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = conjg( ap( kc+j-1 ) )
ap( kc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-1 ) = conjg( ap( kc+kp-1 ) )
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / real( ap( kc ),KIND=dp)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=dp)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = real( ap( kcnext ),KIND=dp) / t
akp1 = real( ap( kc ),KIND=dp) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_zcopy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=dp)
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_zdotc( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_zcopy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_zhpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -real( stdlib${ii}$_zdotc( n-k, work, 1_${ik}$, ap( kcnext+2 ),&
1_${ik}$ ),KIND=dp)
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_zswap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = conjg( ap( kc+j-k ) )
ap( kc+j-k ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-k ) = conjg( ap( kc+kp-k ) )
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_zhptri
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hptri( uplo, n, ap, ipiv, work, info )
!! ZHPTRI: computes the inverse of a complex Hermitian indefinite matrix
!! A in packed storage using the factorization A = U*D*U**H or
!! A = L*D*L**H computed by ZHPTRF.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp
real(${ck}$) :: ak, akp1, d, t
complex(${ck}$) :: akkp1, temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPTRI', -info )
return
end if
! quick return if possible
if( n==0 )return
! check that the diagonal matrix d is nonsingular.
if( upper ) then
! upper triangular storage: examine d from bottom to top
kp = n*( n+1 ) / 2_${ik}$
do info = n, 1, -1
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp - info
end do
else
! lower triangular storage: examine d from top to bottom.
kp = 1_${ik}$
do info = 1, n
if( ipiv( info )>0 .and. ap( kp )==czero )return
kp = kp + n - info + 1_${ik}$
end do
end if
info = 0_${ik}$
if( upper ) then
! compute inv(a) from the factorization a = u*d*u**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
k = 1_${ik}$
kc = 1_${ik}$
30 continue
! if k > n, exit from loop.
if( k>n )go to 50
kcnext = kc + k
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=${ck}$)
! compute column k of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=${ck}$)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+k-1 ) )
ak = real( ap( kc+k-1 ),KIND=${ck}$) / t
akp1 = real( ap( kcnext+k ),KIND=${ck}$) / t
akkp1 = ap( kcnext+k-1 ) / t
d = t*( ak*akp1-one )
ap( kc+k-1 ) = akp1 / d
ap( kcnext+k ) = ak / d
ap( kcnext+k-1 ) = -akkp1 / d
! compute columns k and k+1 of the inverse.
if( k>1_${ik}$ ) then
call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ )
ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),&
KIND=${ck}$)
ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ci}$dotc( k-1, ap( kc ), 1_${ik}$, ap( &
kcnext ),1_${ik}$ )
call stdlib${ii}$_${ci}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ )
ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kcnext &
),1_${ik}$ ),KIND=${ck}$)
end if
kstep = 2_${ik}$
kcnext = kcnext + k + 1_${ik}$
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the leading
! submatrix a(1:k+1,1:k+1)
kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$
call stdlib${ii}$_${ci}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ )
kx = kpc + kp - 1_${ik}$
do j = kp + 1, k - 1
kx = kx + j - 1_${ik}$
temp = conjg( ap( kc+j-1 ) )
ap( kc+j-1 ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-1 ) = conjg( ap( kc+kp-1 ) )
temp = ap( kc+k-1 )
ap( kc+k-1 ) = ap( kpc+kp-1 )
ap( kpc+kp-1 ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc+k+k-1 )
ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
ap( kc+k+kp-1 ) = temp
end if
end if
k = k + kstep
kc = kcnext
go to 30
50 continue
else
! compute inv(a) from the factorization a = l*d*l**h.
! k is the main loop index, increasing from 1 to n in steps of
! 1 or 2, depending on the size of the diagonal blocks.
npp = n*( n+1 ) / 2_${ik}$
k = n
kc = npp
60 continue
! if k < 1, exit from loop.
if( k<1 )go to 80
kcnext = kc - ( n-k+2 )
if( ipiv( k )>0_${ik}$ ) then
! 1 x 1 diagonal block
! invert the diagonal block.
ap( kc ) = one / real( ap( kc ),KIND=${ck}$)
! compute column k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1_${ik}$,czero, ap( kc+1 )&
, 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=${ck}$)
end if
kstep = 1_${ik}$
else
! 2 x 2 diagonal block
! invert the diagonal block.
t = abs( ap( kcnext+1 ) )
ak = real( ap( kcnext ),KIND=${ck}$) / t
akp1 = real( ap( kc ),KIND=${ck}$) / t
akkp1 = ap( kcnext+1 ) / t
d = t*( ak*akp1-one )
ap( kcnext ) = akp1 / d
ap( kc ) = ak / d
ap( kcnext+1 ) = -akkp1 / d
! compute columns k-1 and k of the inverse.
if( k<n ) then
call stdlib${ii}$_${ci}$copy( n-k, ap( kc+1 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kc+1 ), 1_${ik}$ )
ap( kc ) = ap( kc ) - real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$,ap( kc+1 ), 1_${ik}$ ),&
KIND=${ck}$)
ap( kcnext+1 ) = ap( kcnext+1 ) -stdlib${ii}$_${ci}$dotc( n-k, ap( kc+1 ), 1_${ik}$,ap( kcnext+&
2_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ci}$copy( n-k, ap( kcnext+2 ), 1_${ik}$, work, 1_${ik}$ )
call stdlib${ii}$_${ci}$hpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,1_${ik}$, czero, ap( &
kcnext+2 ), 1_${ik}$ )
ap( kcnext ) = ap( kcnext ) -real( stdlib${ii}$_${ci}$dotc( n-k, work, 1_${ik}$, ap( kcnext+2 ),&
1_${ik}$ ),KIND=${ck}$)
end if
kstep = 2_${ik}$
kcnext = kcnext - ( n-k+3 )
end if
kp = abs( ipiv( k ) )
if( kp/=k ) then
! interchange rows and columns k and kp in the trailing
! submatrix a(k-1:n,k-1:n)
kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2_${ik}$ + 1_${ik}$
if( kp<n )call stdlib${ii}$_${ci}$swap( n-kp, ap( kc+kp-k+1 ), 1_${ik}$, ap( kpc+1 ), 1_${ik}$ )
kx = kc + kp - k
do j = k + 1, kp - 1
kx = kx + n - j + 1_${ik}$
temp = conjg( ap( kc+j-k ) )
ap( kc+j-k ) = conjg( ap( kx ) )
ap( kx ) = temp
end do
ap( kc+kp-k ) = conjg( ap( kc+kp-k ) )
temp = ap( kc )
ap( kc ) = ap( kpc )
ap( kpc ) = temp
if( kstep==2_${ik}$ ) then
temp = ap( kc-n+k-1 )
ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
ap( kc-n+kp-1 ) = temp
end if
end if
k = k - kstep
kc = kcnext
go to 60
80 continue
end if
return
end subroutine stdlib${ii}$_${ci}$hptri
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_solve_ldl_comp3
