#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_gen2
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info )
!! SHSEQR computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!! Schur form), and Z is the orthogonal matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input orthogonal
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
real(sp), intent(inout) :: h(ldh,*), z(ldz,*)
real(sp), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_slahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_slahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
real(sp) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: i, kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=sp)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'SHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=sp), work( 1_${ik}$ ) )
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_sgebal ====
do i = 1, ilo - 1
wr( i ) = h( i, i )
wi( i ) = zero
end do
do i = ihi + 1, n
wr( i ) = h( i, i )
wi( i ) = zero
end do
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_slaset( 'A', n, n, zero, one, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
wr( ilo ) = h( ilo, ilo )
wi( ilo ) = zero
return
end if
! ==== stdlib${ii}$_slahqr/stdlib${ii}$_slaqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'SHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_slaqr0 for big matrices; stdlib${ii}$_slahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_slahqr failure! stdlib${ii}$_slaqr0 sometimes succeeds
! . when stdlib${ii}$_slahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_slaqr0 directly. ====
call stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,&
ldz, work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_slaqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_slaqr0. ====
call stdlib${ii}$_slacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = zero
call stdlib${ii}$_slaset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_slaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, &
z, ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_slacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_slaset( 'L', n-2, n-2, zero, zero,&
h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=sp), work( 1_${ik}$ ) )
end if
end subroutine stdlib${ii}$_shseqr
module subroutine stdlib${ii}$_dhseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info )
!! DHSEQR computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!! Schur form), and Z is the orthogonal matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input orthogonal
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
real(dp), intent(inout) :: h(ldh,*), z(ldz,*)
real(dp), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_dlahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_dlahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
real(dp) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: i, kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=dp)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'DHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=dp), work( 1_${ik}$ ) )
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_dgebal ====
do i = 1, ilo - 1
wr( i ) = h( i, i )
wi( i ) = zero
end do
do i = ihi + 1, n
wr( i ) = h( i, i )
wi( i ) = zero
end do
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_dlaset( 'A', n, n, zero, one, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
wr( ilo ) = h( ilo, ilo )
wi( ilo ) = zero
return
end if
! ==== stdlib${ii}$_dlahqr/stdlib${ii}$_dlaqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_dlaqr0 for big matrices; stdlib${ii}$_dlahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_dlahqr failure! stdlib${ii}$_dlaqr0 sometimes succeeds
! . when stdlib${ii}$_dlahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_dlaqr0 directly. ====
call stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,&
ldz, work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_dlaqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_dlaqr0. ====
call stdlib${ii}$_dlacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = zero
call stdlib${ii}$_dlaset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_dlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, &
z, ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_dlacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-2, n-2, zero, zero,&
h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=dp), work( 1_${ik}$ ) )
end if
end subroutine stdlib${ii}$_dhseqr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$hseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info )
!! DHSEQR: computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!! Schur form), and Z is the orthogonal matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input orthogonal
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*)
real(${rk}$), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_${ri}$lahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_${ri}$lahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
real(${rk}$) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: i, kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=${rk}$)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'DHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=${rk}$), work( 1_${ik}$ ) )
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_${ri}$gebal ====
do i = 1, ilo - 1
wr( i ) = h( i, i )
wi( i ) = zero
end do
do i = ihi + 1, n
wr( i ) = h( i, i )
wi( i ) = zero
end do
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_${ri}$laset( 'A', n, n, zero, one, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
wr( ilo ) = h( ilo, ilo )
wi( ilo ) = zero
return
end if
! ==== stdlib${ii}$_${ri}$lahqr/stdlib${ii}$_${ri}$laqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_${ri}$laqr0 for big matrices; stdlib${ii}$_${ri}$lahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
work, lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, &
info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_${ri}$lahqr failure! stdlib${ii}$_${ri}$laqr0 sometimes succeeds
! . when stdlib${ii}$_${ri}$lahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_${ri}$laqr0 directly. ====
call stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,&
ldz, work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_${ri}$laqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_${ri}$laqr0. ====
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = zero
call stdlib${ii}$_${ri}$laset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_${ri}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, &
z, ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_${ri}$lacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-2, n-2, zero, zero,&
h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=${rk}$), work( 1_${ik}$ ) )
end if
end subroutine stdlib${ii}$_${ri}$hseqr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info )
!! CHSEQR computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**H, where T is an upper triangular matrix (the
!! Schur form), and Z is the unitary matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input unitary
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
complex(sp), intent(inout) :: h(ldh,*), z(ldz,*)
complex(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_clahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_clahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
complex(sp) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=sp), zero,KIND=sp)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'CHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_claqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,ldz, work, &
lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( work( 1_${ik}$ ),KIND=sp), real( max( 1_${ik}$,n ),KIND=sp) ), &
zero,KIND=sp)
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_cgebal ====
if( ilo>1_${ik}$ )call stdlib${ii}$_ccopy( ilo-1, h, ldh+1, w, 1_${ik}$ )
if( ihi<n )call stdlib${ii}$_ccopy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1_${ik}$ )
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_claset( 'A', n, n, czero, cone, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
w( ilo ) = h( ilo, ilo )
return
end if
! ==== stdlib${ii}$_clahqr/stdlib${ii}$_claqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'CHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_claqr0 for big matrices; stdlib${ii}$_clahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_claqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, &
lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_clahqr failure! stdlib${ii}$_claqr0 sometimes succeeds
! . when stdlib${ii}$_clahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_claqr0 directly. ====
call stdlib${ii}$_claqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,&
work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_claqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_claqr0. ====
call stdlib${ii}$_clacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = czero
call stdlib${ii}$_claset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_claqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, &
ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_clacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_claset( 'L', n-2, n-2, czero, &
czero, h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=sp),real( work( 1_${ik}$ ),KIND=sp) ), &
zero,KIND=sp)
end if
end subroutine stdlib${ii}$_chseqr
pure module subroutine stdlib${ii}$_zhseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info )
!! ZHSEQR computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**H, where T is an upper triangular matrix (the
!! Schur form), and Z is the unitary matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input unitary
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
complex(dp), intent(inout) :: h(ldh,*), z(ldz,*)
complex(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_zlahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_zlahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
complex(dp) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=dp), zero,KIND=dp)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'ZHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,ldz, work, &
lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( work( 1_${ik}$ ),KIND=dp), real( max( 1_${ik}$,n ),KIND=dp) ), &
zero,KIND=dp)
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_zgebal ====
if( ilo>1_${ik}$ )call stdlib${ii}$_zcopy( ilo-1, h, ldh+1, w, 1_${ik}$ )
if( ihi<n )call stdlib${ii}$_zcopy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1_${ik}$ )
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_zlaset( 'A', n, n, czero, cone, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
w( ilo ) = h( ilo, ilo )
return
end if
! ==== stdlib${ii}$_zlahqr/stdlib${ii}$_zlaqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_zlaqr0 for big matrices; stdlib${ii}$_zlahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, &
lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_zlahqr failure! stdlib${ii}$_zlaqr0 sometimes succeeds
! . when stdlib${ii}$_zlahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_zlaqr0 directly. ====
call stdlib${ii}$_zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,&
work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_zlaqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_zlaqr0. ====
call stdlib${ii}$_zlacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = czero
call stdlib${ii}$_zlaset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, &
ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_zlacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-2, n-2, czero, &
czero, h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=dp),real( work( 1_${ik}$ ),KIND=dp) ), &
zero,KIND=dp)
end if
end subroutine stdlib${ii}$_zhseqr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info )
!! ZHSEQR: computes the eigenvalues of a Hessenberg matrix H
!! and, optionally, the matrices T and Z from the Schur decomposition
!! H = Z T Z**H, where T is an upper triangular matrix (the
!! Schur form), and Z is the unitary matrix of Schur vectors.
!! Optionally Z may be postmultiplied into an input unitary
!! matrix Q so that this routine can give the Schur factorization
!! of a matrix A which has been reduced to the Hessenberg form H
!! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n
integer(${ik}$), intent(out) :: info
character, intent(in) :: compz, job
! Array Arguments
complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*)
complex(${ck}$), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ntiny = 15_${ik}$
integer(${ik}$), parameter :: nl = 49_${ik}$
! ==== matrices of order ntiny or smaller must be processed by
! . stdlib${ii}$_${ci}$lahqr because of insufficient subdiagonal scratch space.
! . (this is a hard limit.) ====
! ==== nl allocates some local workspace to help small matrices
! . through a rare stdlib${ii}$_${ci}$lahqr failure. nl > ntiny = 15 is
! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom-
! . mended. (the default value of nmin is 75.) using nl = 49
! . allows up to six simultaneous shifts and a 16-by-16
! . deflation window. ====
! Local Arrays
complex(${ck}$) :: hl(nl,nl), workl(nl)
! Local Scalars
integer(${ik}$) :: kbot, nmin
logical(lk) :: initz, lquery, wantt, wantz
! Intrinsic Functions
! Executable Statements
! ==== decode and check the input parameters. ====
wantt = stdlib_lsame( job, 'S' )
initz = stdlib_lsame( compz, 'I' )
wantz = initz .or. stdlib_lsame( compz, 'V' )
work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=${ck}$), zero,KIND=${ck}$)
lquery = lwork==-1_${ik}$
info = 0_${ik}$
if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ihi<min( ilo, n ) .or. ihi>n ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
! ==== quick return in case of invalid argument. ====
call stdlib${ii}$_xerbla( 'ZHSEQR', -info )
return
else if( n==0_${ik}$ ) then
! ==== quick return in case n = 0; nothing to do. ====
return
else if( lquery ) then
! ==== quick return in case of a workspace query ====
call stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,ldz, work, &
lwork, info )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( work( 1_${ik}$ ),KIND=${ck}$), real( max( 1_${ik}$,n ),KIND=${ck}$) ), &
zero,KIND=${ck}$)
return
else
! ==== copy eigenvalues isolated by stdlib${ii}$_${ci}$gebal ====
if( ilo>1_${ik}$ )call stdlib${ii}$_${ci}$copy( ilo-1, h, ldh+1, w, 1_${ik}$ )
if( ihi<n )call stdlib${ii}$_${ci}$copy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1_${ik}$ )
! ==== initialize z, if requested ====
if( initz )call stdlib${ii}$_${ci}$laset( 'A', n, n, czero, cone, z, ldz )
! ==== quick return if possible ====
if( ilo==ihi ) then
w( ilo ) = h( ilo, ilo )
return
end if
! ==== stdlib${ii}$_${ci}$lahqr/stdlib${ii}$_${ci}$laqr0 crossover point ====
nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZHSEQR', job( : 1_${ik}$ ) // compz( : 1_${ik}$ ), n,ilo, ihi, lwork )
nmin = max( ntiny, nmin )
! ==== stdlib${ii}$_${ci}$laqr0 for big matrices; stdlib${ii}$_${ci}$lahqr for small ones ====
if( n>nmin ) then
call stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, &
lwork, info )
else
! ==== small matrix ====
call stdlib${ii}$_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info )
if( info>0_${ik}$ ) then
! ==== a rare stdlib${ii}$_${ci}$lahqr failure! stdlib${ii}$_${ci}$laqr0 sometimes succeeds
! . when stdlib${ii}$_${ci}$lahqr fails. ====
kbot = info
if( n>=nl ) then
! ==== larger matrices have enough subdiagonal scratch
! . space to call stdlib${ii}$_${ci}$laqr0 directly. ====
call stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,&
work, lwork, info )
else
! ==== tiny matrices don't have enough subdiagonal
! . scratch space to benefit from stdlib${ii}$_${ci}$laqr0. hence,
! . tiny matrices must be copied into a larger
! . array before calling stdlib${ii}$_${ci}$laqr0. ====
call stdlib${ii}$_${ci}$lacpy( 'A', n, n, h, ldh, hl, nl )
hl( n+1, n ) = czero
call stdlib${ii}$_${ci}$laset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl )
call stdlib${ii}$_${ci}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, &
ldz, workl, nl, info )
if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_${ci}$lacpy( 'A', n, n, hl, nl, h, ldh )
end if
end if
end if
! ==== clear out the trash, if necessary. ====
if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-2, n-2, czero, &
czero, h( 3_${ik}$, 1_${ik}$ ), ldh )
! ==== ensure reported workspace size is backward-compatible with
! . previous lapack versions. ====
work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=${ck}$),real( work( 1_${ik}$ ),KIND=${ck}$) ), &
zero,KIND=${ck}$)
end if
end subroutine stdlib${ii}$_${ci}$hseqr
#:endif
#:endfor
module subroutine stdlib${ii}$_shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, &
!! SHSEIN uses inverse iteration to find specified right and/or left
!! eigenvectors of a real upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
mm, m, work, ifaill,ifailr, 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) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(sp), intent(in) :: h(ldh,*), wi(*)
real(sp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork
real(sp) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors, and standardize the array select.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
select( k ) = .false.
else
if( wi( k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) ) then
select( k ) = .true.
m = m + 2_${ik}$
end if
end if
end if
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -13_${ik}$
else if( mm<m ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
ldwork = n + 1_${ik}$
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ksr = 1_${ik}$
loop_120: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are zero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==zero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==zero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_slanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work )
if( stdlib${ii}$_sisnan( hnorm ) ) then
info = -6_${ik}$
return
else if( hnorm>zero ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wkr = wr( k )
wki = wi( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. abs( wr( i )-wkr )+abs( wi( i )-wki )<eps3 ) &
then
wkr = wkr + eps3
go to 60
end if
end do
wr( k ) = wkr
pair = wki/=zero
if( pair ) then
ksi = ksr + 1_${ik}$
else
ksi = ksr
end if
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_slaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( &
kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, &
iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifaill( ksr ) = k
ifaill( ksi ) = k
else
ifaill( ksr ) = 0_${ik}$
ifaill( ksi ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ksr ) = zero
end do
if( pair ) then
do i = 1, kl - 1
vl( i, ksi ) = zero
end do
end if
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_slaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, &
ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifailr( ksr ) = k
ifailr( ksi ) = k
else
ifailr( ksr ) = 0_${ik}$
ifailr( ksi ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ksr ) = zero
end do
if( pair ) then
do i = kr + 1, n
vr( i, ksi ) = zero
end do
end if
end if
if( pair ) then
ksr = ksr + 2_${ik}$
else
ksr = ksr + 1_${ik}$
end if
end if
end do loop_120
return
end subroutine stdlib${ii}$_shsein
module subroutine stdlib${ii}$_dhsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, &
!! DHSEIN uses inverse iteration to find specified right and/or left
!! eigenvectors of a real upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
mm, m, work, ifaill,ifailr, 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) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(dp), intent(in) :: h(ldh,*), wi(*)
real(dp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork
real(dp) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors, and standardize the array select.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
select( k ) = .false.
else
if( wi( k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) ) then
select( k ) = .true.
m = m + 2_${ik}$
end if
end if
end if
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -13_${ik}$
else if( mm<m ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
ldwork = n + 1_${ik}$
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ksr = 1_${ik}$
loop_120: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are zero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==zero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==zero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_dlanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work )
if( stdlib${ii}$_disnan( hnorm ) ) then
info = -6_${ik}$
return
else if( hnorm>zero ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wkr = wr( k )
wki = wi( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. abs( wr( i )-wkr )+abs( wi( i )-wki )<eps3 ) &
then
wkr = wkr + eps3
go to 60
end if
end do
wr( k ) = wkr
pair = wki/=zero
if( pair ) then
ksi = ksr + 1_${ik}$
else
ksi = ksr
end if
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_dlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( &
kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, &
iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifaill( ksr ) = k
ifaill( ksi ) = k
else
ifaill( ksr ) = 0_${ik}$
ifaill( ksi ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ksr ) = zero
end do
if( pair ) then
do i = 1, kl - 1
vl( i, ksi ) = zero
end do
end if
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_dlaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, &
ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifailr( ksr ) = k
ifailr( ksi ) = k
else
ifailr( ksr ) = 0_${ik}$
ifailr( ksi ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ksr ) = zero
end do
if( pair ) then
do i = kr + 1, n
vr( i, ksi ) = zero
end do
end if
end if
if( pair ) then
ksr = ksr + 2_${ik}$
else
ksr = ksr + 1_${ik}$
end if
end if
end do loop_120
return
end subroutine stdlib${ii}$_dhsein
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$hsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, &
!! DHSEIN: uses inverse iteration to find specified right and/or left
!! eigenvectors of a real upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
mm, m, work, ifaill,ifailr, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(${rk}$), intent(in) :: h(ldh,*), wi(*)
real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork
real(${rk}$) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors, and standardize the array select.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
select( k ) = .false.
else
if( wi( k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) ) then
select( k ) = .true.
m = m + 2_${ik}$
end if
end if
end if
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -13_${ik}$
else if( mm<m ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
ldwork = n + 1_${ik}$
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ksr = 1_${ik}$
loop_120: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are zero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==zero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==zero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_${ri}$lanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work )
if( stdlib${ii}$_${ri}$isnan( hnorm ) ) then
info = -6_${ik}$
return
else if( hnorm>zero ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wkr = wr( k )
wki = wi( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. abs( wr( i )-wkr )+abs( wi( i )-wki )<eps3 ) &
then
wkr = wkr + eps3
go to 60
end if
end do
wr( k ) = wkr
pair = wki/=zero
if( pair ) then
ksi = ksr + 1_${ik}$
else
ksi = ksr
end if
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_${ri}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( &
kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, &
iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifaill( ksr ) = k
ifaill( ksi ) = k
else
ifaill( ksr ) = 0_${ik}$
ifaill( ksi ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ksr ) = zero
end do
if( pair ) then
do i = 1, kl - 1
vl( i, ksi ) = zero
end do
end if
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_${ri}$laein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, &
ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo )
if( iinfo>0_${ik}$ ) then
if( pair ) then
info = info + 2_${ik}$
else
info = info + 1_${ik}$
end if
ifailr( ksr ) = k
ifailr( ksi ) = k
else
ifailr( ksr ) = 0_${ik}$
ifailr( ksi ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ksr ) = zero
end do
if( pair ) then
do i = kr + 1, n
vr( i, ksi ) = zero
end do
end if
end if
if( pair ) then
ksr = ksr + 2_${ik}$
else
ksr = ksr + 1_${ik}$
end if
end if
end do loop_120
return
end subroutine stdlib${ii}$_${ri}$hsein
#:endif
#:endfor
module subroutine stdlib${ii}$_chsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, mm, &
!! CHSEIN uses inverse iteration to find specified right and/or left
!! eigenvectors of a complex upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
m, work, rwork, ifaill,ifailr, 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) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(in) :: h(ldh,*)
complex(sp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), w(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ks, ldwork
real(sp) :: eps3, hnorm, smlnum, ulp, unfl
complex(sp) :: cdum, wk
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -12_${ik}$
else if( mm<m ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
ldwork = n
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ks = 1_${ik}$
loop_100: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are czero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==czero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==czero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_clanhs( 'I', kr-kl+1, h( kl, kl ), ldh, rwork )
if( stdlib${ii}$_sisnan( hnorm ) ) then
info = -6_${ik}$
return
else if( (hnorm>zero) ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wk = w( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. cabs1( w( i )-wk )<eps3 ) then
wk = wk + eps3
go to 60
end if
end do
w( k ) = wk
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_claein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )&
, work, ldwork, rwork, eps3,smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifaill( ks ) = k
else
ifaill( ks ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ks ) = czero
end do
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_claein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, &
rwork, eps3, smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifailr( ks ) = k
else
ifailr( ks ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ks ) = czero
end do
end if
ks = ks + 1_${ik}$
end if
end do loop_100
return
end subroutine stdlib${ii}$_chsein
module subroutine stdlib${ii}$_zhsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, mm, &
!! ZHSEIN uses inverse iteration to find specified right and/or left
!! eigenvectors of a complex upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
m, work, rwork, ifaill,ifailr, 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) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(in) :: h(ldh,*)
complex(dp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), w(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ks, ldwork
real(dp) :: eps3, hnorm, smlnum, ulp, unfl
complex(dp) :: cdum, wk
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -12_${ik}$
else if( mm<m ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
ldwork = n
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ks = 1_${ik}$
loop_100: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are czero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==czero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==czero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_zlanhs( 'I', kr-kl+1, h( kl, kl ), ldh, rwork )
if( stdlib${ii}$_disnan( hnorm ) ) then
info = -6_${ik}$
return
else if( hnorm>zero ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wk = w( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. cabs1( w( i )-wk )<eps3 ) then
wk = wk + eps3
go to 60
end if
end do
w( k ) = wk
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_zlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )&
, work, ldwork, rwork, eps3,smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifaill( ks ) = k
else
ifaill( ks ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ks ) = czero
end do
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_zlaein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, &
rwork, eps3, smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifailr( ks ) = k
else
ifailr( ks ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ks ) = czero
end do
end if
ks = ks + 1_${ik}$
end if
end do loop_100
return
end subroutine stdlib${ii}$_zhsein
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, mm, &
!! ZHSEIN: uses inverse iteration to find specified right and/or left
!! eigenvectors of a complex upper Hessenberg matrix H.
!! The right eigenvector x and the left eigenvector y of the matrix H
!! corresponding to an eigenvalue w are defined by:
!! H * x = w * x, y**h * H = w * y**h
!! where y**h denotes the conjugate transpose of the vector y.
m, work, rwork, ifaill,ifailr, 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) :: eigsrc, initv, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: ifaill(*), ifailr(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(in) :: h(ldh,*)
complex(${ck}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*), w(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: bothv, fromqr, leftv, noinit, rightv
integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ks, ldwork
real(${ck}$) :: eps3, hnorm, smlnum, ulp, unfl
complex(${ck}$) :: cdum, wk
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters.
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
fromqr = stdlib_lsame( eigsrc, 'Q' )
noinit = stdlib_lsame( initv, 'N' )
! set m to the number of columns required to store the selected
! eigenvectors.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then
info = -2_${ik}$
else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( ldh<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -12_${ik}$
else if( mm<m ) then
info = -13_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHSEIN', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set machine-dependent constants.
unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
ldwork = n
kl = 1_${ik}$
kln = 0_${ik}$
if( fromqr ) then
kr = 0_${ik}$
else
kr = n
end if
ks = 1_${ik}$
loop_100: do k = 1, n
if( select( k ) ) then
! compute eigenvector(s) corresponding to w(k).
if( fromqr ) then
! if affiliation of eigenvalues is known, check whether
! the matrix splits.
! determine kl and kr such that 1 <= kl <= k <= kr <= n
! and h(kl,kl-1) and h(kr+1,kr) are czero (or kl = 1 or
! kr = n).
! then inverse iteration can be performed with the
! submatrix h(kl:n,kl:n) for a left eigenvector, and with
! the submatrix h(1:kr,1:kr) for a right eigenvector.
do i = k, kl + 1, -1
if( h( i, i-1 )==czero )go to 30
end do
30 continue
kl = i
if( k>kr ) then
do i = k, n - 1
if( h( i+1, i )==czero )go to 50
end do
50 continue
kr = i
end if
end if
if( kl/=kln ) then
kln = kl
! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it
! has not ben computed before.
hnorm = stdlib${ii}$_${ci}$lanhs( 'I', kr-kl+1, h( kl, kl ), ldh, rwork )
if( stdlib${ii}$_${c2ri(ci)}$isnan( hnorm ) ) then
info = -6_${ik}$
return
else if( hnorm>zero ) then
eps3 = hnorm*ulp
else
eps3 = smlnum
end if
end if
! perturb eigenvalue if it is close to any previous
! selected eigenvalues affiliated to the submatrix
! h(kl:kr,kl:kr). close roots are modified by eps3.
wk = w( k )
60 continue
do i = k - 1, kl, -1
if( select( i ) .and. cabs1( w( i )-wk )<eps3 ) then
wk = wk + eps3
go to 60
end if
end do
w( k ) = wk
if( leftv ) then
! compute left eigenvector.
call stdlib${ii}$_${ci}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )&
, work, ldwork, rwork, eps3,smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifaill( ks ) = k
else
ifaill( ks ) = 0_${ik}$
end if
do i = 1, kl - 1
vl( i, ks ) = czero
end do
end if
if( rightv ) then
! compute right eigenvector.
call stdlib${ii}$_${ci}$laein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, &
rwork, eps3, smlnum, iinfo )
if( iinfo>0_${ik}$ ) then
info = info + 1_${ik}$
ifailr( ks ) = k
else
ifailr( ks ) = 0_${ik}$
end if
do i = kr + 1, n
vr( i, ks ) = czero
end do
end if
ks = ks + 1_${ik}$
end if
end do loop_100
return
end subroutine stdlib${ii}$_${ci}$hsein
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! STREVC computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
work, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(sp), intent(in) :: t(ldt,*)
real(sp), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2
real(sp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(sp) :: x(2_${ik}$,2_${ik}$)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_slabad( unfl, ovfl )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
n2 = 2_${ik}$*n
if( rightv ) then
! compute right eigenvectors.
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==1 )go to 130
if( ki==1 )go to 40
if( t( ki, ki-1 )==zero )go to 40
ip = -1_${ik}$
40 continue
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )go to 130
else
if( .not.select( ki-1 ) )go to 130
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real right eigenvector
work( ki+n ) = one
! form right-hand side
do k = 1, ki - 1
work( k+n ) = -t( k, ki )
end do
! solve the upper quasi-triangular system:
! (t(1:ki-1,1:ki-1) - wr)*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, &
work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex right eigenvector.
! initial solve
! [ (t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i* wi)]*x = 0.
! [ (t(ki,ki-1) t(ki,ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1+n ) = one
work( ki+n2 ) = wi / t( ki-1, ki )
else
work( ki-1+n ) = -wi / t( ki, ki-1 )
work( ki+n2 ) = one
end if
work( ki+n ) = zero
work( ki-1+n2 ) = zero
! form right-hand side
do k = 1, ki - 2
work( k+n ) = -work( ki-1+n )*t( k, ki-1 )
work( k+n2 ) = -work( ki+n2 )*t( k, ki )
end do
! solve upper quasi-triangular system:
! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else
if( ki>2_${ik}$ ) then
call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-&
1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( &
ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_sscal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
end if
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
130 continue
if( ip==1_${ik}$ )ip = 0_${ik}$
if( ip==-1_${ik}$ )ip = 1_${ik}$
end do loop_140
end if
if( leftv ) then
! compute left eigenvectors.
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==-1 )go to 250
if( ki==n )go to 150
if( t( ki+1, ki )==zero )go to 150
ip = 1_${ik}$
150 continue
if( somev ) then
if( .not.select( ki ) )go to 250
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real left eigenvector.
work( ki+n ) = one
! form right-hand side
do k = ki + 1, n
work( k+n ) = -t( ki, k )
end do
! solve the quasi-triangular system:
! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
! solve (t(j,j)-wr)**t*x = work
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,&
work( ki+1+n ), 1_${ik}$ )
! solve
! [t(j,j)-wr t(j,j+1) ]**t* x = scale*( work1 )
! [t(j+1,j) t(j+1,j+1)-wr] ( work2 )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_scopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else
if( ki<n )call stdlib${ii}$_sgemv( 'N', n, n-ki, one, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1+n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex left eigenvector.
! initial solve:
! ((t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi))*x = 0.
! ((t(ki+1,ki) t(ki+1,ki+1)) )
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki+n ) = wi / t( ki, ki+1 )
work( ki+1+n2 ) = one
else
work( ki+n ) = one
work( ki+1+n2 ) = -wi / t( ki+1, ki )
end if
work( ki+1+n ) = zero
work( ki+n2 ) = zero
! form right-hand side
do k = ki + 2, n
work( k+n ) = -work( ki+n )*t( ki, k )
work( k+n2 ) = -work( ki+1+n2 )*t( ki+1, k )
end do
! solve complex quasi-triangular system:
! ( t(ki+2,n:ki+2,n) - (wr-i*wi) )*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n ), 1_${ik}$ )
work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n2 ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b
! ([t(j+1,j) t(j+1,j+1)] )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_scopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_scopy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else
if( ki<n-1 ) then
call stdlib${ii}$_sgemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n2 ), 1_${ik}$,work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_sscal( n, work( ki+n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
end if
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
250 continue
if( ip==-1_${ik}$ )ip = 0_${ik}$
if( ip==1_${ik}$ )ip = -1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_strevc
pure module subroutine stdlib${ii}$_dtrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! DTREVC computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
work, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(dp), intent(in) :: t(ldt,*)
real(dp), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2
real(dp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(dp) :: x(2_${ik}$,2_${ik}$)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_dlabad( unfl, ovfl )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
n2 = 2_${ik}$*n
if( rightv ) then
! compute right eigenvectors.
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==1 )go to 130
if( ki==1 )go to 40
if( t( ki, ki-1 )==zero )go to 40
ip = -1_${ik}$
40 continue
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )go to 130
else
if( .not.select( ki-1 ) )go to 130
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real right eigenvector
work( ki+n ) = one
! form right-hand side
do k = 1, ki - 1
work( k+n ) = -t( k, ki )
end do
! solve the upper quasi-triangular system:
! (t(1:ki-1,1:ki-1) - wr)*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, &
work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex right eigenvector.
! initial solve
! [ (t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i* wi)]*x = 0.
! [ (t(ki,ki-1) t(ki,ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1+n ) = one
work( ki+n2 ) = wi / t( ki-1, ki )
else
work( ki-1+n ) = -wi / t( ki, ki-1 )
work( ki+n2 ) = one
end if
work( ki+n ) = zero
work( ki-1+n2 ) = zero
! form right-hand side
do k = 1, ki - 2
work( k+n ) = -work( ki-1+n )*t( k, ki-1 )
work( k+n2 ) = -work( ki+n2 )*t( k, ki )
end do
! solve upper quasi-triangular system:
! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else
if( ki>2_${ik}$ ) then
call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-&
1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( &
ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_dscal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
end if
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
130 continue
if( ip==1_${ik}$ )ip = 0_${ik}$
if( ip==-1_${ik}$ )ip = 1_${ik}$
end do loop_140
end if
if( leftv ) then
! compute left eigenvectors.
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==-1 )go to 250
if( ki==n )go to 150
if( t( ki+1, ki )==zero )go to 150
ip = 1_${ik}$
150 continue
if( somev ) then
if( .not.select( ki ) )go to 250
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real left eigenvector.
work( ki+n ) = one
! form right-hand side
do k = ki + 1, n
work( k+n ) = -t( ki, k )
end do
! solve the quasi-triangular system:
! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
! solve (t(j,j)-wr)**t*x = work
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,&
work( ki+1+n ), 1_${ik}$ )
! solve
! [t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 )
! [t(j+1,j) t(j+1,j+1)-wr] ( work2 )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_dcopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else
if( ki<n )call stdlib${ii}$_dgemv( 'N', n, n-ki, one, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1+n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex left eigenvector.
! initial solve:
! ((t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi))*x = 0.
! ((t(ki+1,ki) t(ki+1,ki+1)) )
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki+n ) = wi / t( ki, ki+1 )
work( ki+1+n2 ) = one
else
work( ki+n ) = one
work( ki+1+n2 ) = -wi / t( ki+1, ki )
end if
work( ki+1+n ) = zero
work( ki+n2 ) = zero
! form right-hand side
do k = ki + 2, n
work( k+n ) = -work( ki+n )*t( ki, k )
work( k+n2 ) = -work( ki+1+n2 )*t( ki+1, k )
end do
! solve complex quasi-triangular system:
! ( t(ki+2,n:ki+2,n) - (wr-i*wi) )*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n ), 1_${ik}$ )
work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n2 ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b
! ([t(j+1,j) t(j+1,j+1)] )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_dcopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else
if( ki<n-1 ) then
call stdlib${ii}$_dgemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n2 ), 1_${ik}$,work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_dscal( n, work( ki+n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
end if
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
250 continue
if( ip==-1_${ik}$ )ip = 0_${ik}$
if( ip==1_${ik}$ )ip = -1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_dtrevc
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! DTREVC: computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
work, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(${rk}$), intent(in) :: t(ldt,*)
real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2
real(${rk}$) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(${rk}$) :: x(2_${ik}$,2_${ik}$)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_${ri}$labad( unfl, ovfl )
ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
n2 = 2_${ik}$*n
if( rightv ) then
! compute right eigenvectors.
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==1 )go to 130
if( ki==1 )go to 40
if( t( ki, ki-1 )==zero )go to 40
ip = -1_${ik}$
40 continue
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )go to 130
else
if( .not.select( ki-1 ) )go to 130
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real right eigenvector
work( ki+n ) = one
! form right-hand side
do k = 1, ki - 1
work( k+n ) = -t( k, ki )
end do
! solve the upper quasi-triangular system:
! (t(1:ki-1,1:ki-1) - wr)*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, &
work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex right eigenvector.
! initial solve
! [ (t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i* wi)]*x = 0.
! [ (t(ki,ki-1) t(ki,ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1+n ) = one
work( ki+n2 ) = wi / t( ki-1, ki )
else
work( ki-1+n ) = -wi / t( ki, ki-1 )
work( ki+n2 ) = one
end if
work( ki+n ) = zero
work( ki-1+n2 ) = zero
! form right-hand side
do k = 1, ki - 2
work( k+n ) = -work( ki-1+n )*t( k, ki-1 )
work( k+n2 ) = -work( ki+n2 )*t( k, ki )
end do
! solve upper quasi-triangular system:
! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else
if( ki>2_${ik}$ ) then
call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-&
1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( &
ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$scal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
end if
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
130 continue
if( ip==1_${ik}$ )ip = 0_${ik}$
if( ip==-1_${ik}$ )ip = 1_${ik}$
end do loop_140
end if
if( leftv ) then
! compute left eigenvectors.
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==-1 )go to 250
if( ki==n )go to 150
if( t( ki+1, ki )==zero )go to 150
ip = 1_${ik}$
150 continue
if( somev ) then
if( .not.select( ki ) )go to 250
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! real left eigenvector.
work( ki+n ) = one
! form right-hand side
do k = ki + 1, n
work( k+n ) = -t( ki, k )
end do
! solve the quasi-triangular system:
! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
! solve (t(j,j)-wr)**t*x = work
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( &
ki+1+n ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,&
work( ki+1+n ), 1_${ik}$ )
! solve
! [t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 )
! [t(j+1,j) t(j+1,j+1)-wr] ( work2 )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else
if( ki<n )call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki, one, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1+n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
else
! complex left eigenvector.
! initial solve:
! ((t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi))*x = 0.
! ((t(ki+1,ki) t(ki+1,ki+1)) )
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki+n ) = wi / t( ki, ki+1 )
work( ki+1+n2 ) = one
else
work( ki+n ) = one
work( ki+1+n2 ) = -wi / t( ki+1, ki )
end if
work( ki+1+n ) = zero
work( ki+n2 ) = zero
! form right-hand side
do k = ki + 2, n
work( k+n ) = -work( ki+n )*t( ki, k )
work( k+n2 ) = -work( ki+1+n2 )*t( ki+1, k )
end do
! solve complex quasi-triangular system:
! ( t(ki+2,n:ki+2,n) - (wr-i*wi) )*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n ), 1_${ik}$ )
work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( &
ki+2+n2 ), 1_${ik}$ )
work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n ), 1_${ik}$ )
work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,&
work( ki+2+n2 ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b
! ([t(j+1,j) t(j+1,j+1)] )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ )
end if
work( j+n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else
if( ki<n-1 ) then
call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n ), 1_${ik}$, work( ki+n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki-1, one, vl( 1_${ik}$, ki+2 ),ldvl, work( ki+2+&
n2 ), 1_${ik}$,work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$scal( n, work( ki+n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, work( ki+1+n2 ), vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
end if
end if
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
250 continue
if( ip==-1_${ik}$ )ip = 0_${ik}$
if( ip==1_${ik}$ )ip = -1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_${ri}$trevc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! CTREVC computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
complex(sp), parameter :: cmzero = (0.0e+0_sp,0.0e+0_sp)
complex(sp), parameter :: cmone = (1.0e+0_sp,0.0e+0_sp)
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki
real(sp) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(sp) :: cdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_slabad( unfl, ovfl )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i+n ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_scasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! compute right eigenvectors.
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( 1_${ik}$ ) = cmone
! form right-hand side.
do k = 1, ki - 1
work( k ) = -t( k, ki )
end do
! solve the triangular system:
! (t(1:ki-1,1:ki-1) - t(ki,ki))*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ ), scale, rwork,info )
work( ki ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_ccopy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_csscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = cmzero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_cgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, &
cmplx( scale,KIND=sp), vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_csscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k+n )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! compute left eigenvectors.
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( n ) = cmone
! form right-hand side.
do k = ki + 1, n
work( k ) = -conjg( t( ki, k ) )
end do
! solve the triangular system:
! (t(ki+1:n,ki+1:n) - t(ki,ki))**h*x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 ), scale, rwork, info )
work( ki ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_ccopy( n-ki+1, work( ki ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_csscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = cmzero
end do
else
if( ki<n )call stdlib${ii}$_cgemv( 'N', n, n-ki, cmone, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 ), 1_${ik}$, cmplx( scale,KIND=sp),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_csscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k+n )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_ctrevc
pure module subroutine stdlib${ii}$_ztrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! ZTREVC computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
complex(dp), parameter :: cmzero = (0.0e+0_dp,0.0e+0_dp)
complex(dp), parameter :: cmone = (1.0e+0_dp,0.0e+0_dp)
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki
real(dp) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(dp) :: cdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_dlabad( unfl, ovfl )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i+n ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_dzasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! compute right eigenvectors.
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( 1_${ik}$ ) = cmone
! form right-hand side.
do k = 1, ki - 1
work( k ) = -t( k, ki )
end do
! solve the triangular system:
! (t(1:ki-1,1:ki-1) - t(ki,ki))*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ ), scale, rwork,info )
work( ki ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_zcopy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_zdscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = cmzero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, &
cmplx( scale,KIND=dp), vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_zdscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k+n )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! compute left eigenvectors.
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( n ) = cmone
! form right-hand side.
do k = ki + 1, n
work( k ) = -conjg( t( ki, k ) )
end do
! solve the triangular system:
! (t(ki+1:n,ki+1:n) - t(ki,ki))**h * x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 ), scale, rwork, info )
work( ki ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_zcopy( n-ki+1, work( ki ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_zdscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = cmzero
end do
else
if( ki<n )call stdlib${ii}$_zgemv( 'N', n, n-ki, cmone, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 ), 1_${ik}$, cmplx( scale,KIND=dp),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_zdscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k+n )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_ztrevc
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! ZTREVC: computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Parameters
complex(${ck}$), parameter :: cmzero = (0.0e+0_${ck}$,0.0e+0_${ck}$)
complex(${ck}$), parameter :: cmone = (1.0e+0_${ck}$,0.0e+0_${ck}$)
! Local Scalars
logical(lk) :: allv, bothv, leftv, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki
real(${ck}$) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(${ck}$) :: cdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREVC', -info )
return
end if
! quick return if possible.
if( n==0 )return
! set the constants to control overflow.
unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_${c2ri(ci)}$labad( unfl, ovfl )
ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i+n ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! compute right eigenvectors.
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( 1_${ik}$ ) = cmone
! form right-hand side.
do k = 1, ki - 1
work( k ) = -t( k, ki )
end do
! solve the triangular system:
! (t(1:ki-1,1:ki-1) - t(ki,ki))*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ ), scale, rwork,info )
work( ki ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
call stdlib${ii}$_${ci}$copy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_${ci}$dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = cmzero
end do
else
if( ki>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, &
cmplx( scale,KIND=${ck}$), vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_${ci}$dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k+n )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! compute left eigenvectors.
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
work( n ) = cmone
! form right-hand side.
do k = ki + 1, n
work( k ) = -conjg( t( ki, k ) )
end do
! solve the triangular system:
! (t(ki+1:n,ki+1:n) - t(ki,ki))**h * x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 ), scale, rwork, info )
work( ki ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
call stdlib${ii}$_${ci}$copy( n-ki+1, work( ki ), 1_${ik}$, vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_${ci}$dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = cmzero
end do
else
if( ki<n )call stdlib${ii}$_${ci}$gemv( 'N', n, n-ki, cmone, vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 ), 1_${ik}$, cmplx( scale,KIND=${ck}$),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_${ci}$dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
end if
! set back the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k+n )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_${ci}$trevc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m, &
!! STREVC3 computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**T)*T = w*(y**T)
!! where y**T denotes the transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(sp), intent(in) :: t(ldt,*)
real(sp), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, iv, maxwrk, nb, &
ki2
real(sp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(sp) :: x(2_${ik}$,2_${ik}$)
integer(${ik}$) :: iscomplex(nbmax)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'STREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
lquery = ( lwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_slaset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_slabad( unfl, ovfl )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
! iscomplex array stores ip for each column in current block.
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! for complex right vector, uses iv-1 for real part and iv for complex part.
! non-blocked version always uses iv=2;
! blocked version starts with iv=nb, goes down to 1 or 2.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 2_${ik}$
if( nb>2_${ik}$ ) then
iv = nb
end if
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==-1_${ik}$ ) then
! previous iteration (ki+1) was second of conjugate pair,
! so this ki is first of conjugate pair; skip to end of loop
ip = 1_${ik}$
cycle loop_140
else if( ki==1_${ik}$ ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki, ki-1 )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is second of conjugate pair
ip = -1_${ik}$
end if
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )cycle loop_140
else
if( .not.select( ki-1 ) )cycle loop_140
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real right eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_scopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), &
1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex right eigenvector.
! initial solve
! [ ( t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i*wi) ]*x = 0.
! [ ( t(ki, ki-1) t(ki, ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1 + (iv-1)*n ) = one
work( ki + (iv )*n ) = wi / t( ki-1, ki )
else
work( ki-1 + (iv-1)*n ) = -wi / t( ki, ki-1 )
work( ki + (iv )*n ) = one
end if
work( ki + (iv-1)*n ) = zero
work( ki-1 + (iv )*n ) = zero
! form right-hand side.
do k = 1, ki - 2
work( k+(iv-1)*n ) = -work( ki-1+(iv-1)*n )*t(k,ki-1)
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(k,ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),&
1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), &
1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), &
1_${ik}$ )
call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_scopy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ )
call stdlib${ii}$_scopy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>2_${ik}$ ) then
call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), &
1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,&
work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_sscal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_sscal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + (iv-1)*n ) = zero
work( k + (iv )*n ) = zero
end do
iscomplex( iv-1 ) = -ip
iscomplex( iv ) = ip
iv = iv - 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki-1 and ki)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki - 1_${ik}$
end if
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then
call stdlib${ii}$_sgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
if( iscomplex(k)==0_${ik}$ ) then
! real eigenvector
ii = stdlib${ii}$_isamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$ ) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_sscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_slacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if ! blocked back-transform
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
end do loop_140
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! for complex left vector, uses iv for real part and iv+1 for complex part.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb-1 or nb.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 1_${ik}$
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==1_${ik}$ ) then
! previous iteration (ki-1) was first of conjugate pair,
! so this ki is second of conjugate pair; skip to end of loop
ip = -1_${ik}$
cycle loop_260
else if( ki==n ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki+1, ki )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is first of conjugate pair
ip = 1_${ik}$
end if
if( somev ) then
if( .not.select( ki ) )cycle loop_260
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real left eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -t( ki, k )
end do
! solve transposed quasi-triangular system:
! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
! solve [ t(j,j) - wr ]**t * x = work
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+iv*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j+1 )&
, 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ )
! solve
! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 )
! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_scopy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_sgemv( 'N', n, n-ki, one,vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 + iv*n ), 1_${ik}$,work( ki + iv*n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_isamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex left eigenvector.
! initial solve:
! [ ( t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi) ]*x = 0.
! [ ( t(ki+1,ki) t(ki+1,ki+1) ) ]
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki + (iv )*n ) = wi / t( ki, ki+1 )
work( ki+1 + (iv+1)*n ) = one
else
work( ki + (iv )*n ) = one
work( ki+1 + (iv+1)*n ) = -wi / t( ki+1, ki )
end if
work( ki+1 + (iv )*n ) = zero
work( ki + (iv+1)*n ) = zero
! form right-hand side.
do k = ki + 2, n
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(ki, k)
work( k+(iv+1)*n ) = -work( ki+1+(iv+1)*n )*t(ki+1,k)
end do
! solve transposed quasi-triangular system:
! [ t(ki+2:n,ki+2:n)**t - (wr-i*wi) ]*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j )&
, 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2,&
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2,&
j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+&
2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b
! [ (t(j+1,j) t(j+1,j+1)) ]
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ),vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_scopy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_scopy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n-1 ) then
call stdlib${ii}$_sgemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv)*n ), 1_${ik}$,work( ki + (iv)*n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv+1)*n ), 1_${ik}$,work( ki+1 + (iv+1)*n ),vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_sscal( n, work(ki+ (iv )*n), vl(1_${ik}$, ki ), 1_${ik}$)
call stdlib${ii}$_sscal( n, work(ki+1+(iv+1)*n), vl(1_${ik}$, ki+1), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + (iv )*n ) = zero
work( k + (iv+1)*n ) = zero
end do
iscomplex( iv ) = ip
iscomplex( iv+1 ) = -ip
iv = iv + 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki and ki+1)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki + 1_${ik}$
end if
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv>=nb-1) .or. (ki2==n) ) then
call stdlib${ii}$_sgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,&
work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
if( iscomplex(k)==0_${ik}$) then
! real eigenvector
ii = stdlib${ii}$_isamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_sscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_slacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if ! blocked back-transform
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_strevc3
pure module subroutine stdlib${ii}$_dtrevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m, &
!! DTREVC3 computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**T)*T = w*(y**T)
!! where y**T denotes the transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(dp), intent(in) :: t(ldt,*)
real(dp), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, iv, maxwrk, nb, &
ki2
real(dp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(dp) :: x(2_${ik}$,2_${ik}$)
integer(${ik}$) :: iscomplex(nbmax)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DTREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
lquery = ( lwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_dlaset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_dlabad( unfl, ovfl )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
! iscomplex array stores ip for each column in current block.
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! for complex right vector, uses iv-1 for real part and iv for complex part.
! non-blocked version always uses iv=2;
! blocked version starts with iv=nb, goes down to 1 or 2.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 2_${ik}$
if( nb>2_${ik}$ ) then
iv = nb
end if
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==-1_${ik}$ ) then
! previous iteration (ki+1) was second of conjugate pair,
! so this ki is first of conjugate pair; skip to end of loop
ip = 1_${ik}$
cycle loop_140
else if( ki==1_${ik}$ ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki, ki-1 )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is second of conjugate pair
ip = -1_${ik}$
end if
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )cycle loop_140
else
if( .not.select( ki-1 ) )cycle loop_140
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real right eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), &
1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex right eigenvector.
! initial solve
! [ ( t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i*wi) ]*x = 0.
! [ ( t(ki, ki-1) t(ki, ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1 + (iv-1)*n ) = one
work( ki + (iv )*n ) = wi / t( ki-1, ki )
else
work( ki-1 + (iv-1)*n ) = -wi / t( ki, ki-1 )
work( ki + (iv )*n ) = one
end if
work( ki + (iv-1)*n ) = zero
work( ki-1 + (iv )*n ) = zero
! form right-hand side.
do k = 1, ki - 2
work( k+(iv-1)*n ) = -work( ki-1+(iv-1)*n )*t(k,ki-1)
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(k,ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),&
1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), &
1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), &
1_${ik}$ )
call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ )
call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>2_${ik}$ ) then
call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), &
1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,&
work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_dscal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_dscal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + (iv-1)*n ) = zero
work( k + (iv )*n ) = zero
end do
iscomplex( iv-1 ) = -ip
iscomplex( iv ) = ip
iv = iv - 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki-1 and ki)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki - 1_${ik}$
end if
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then
call stdlib${ii}$_dgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
if( iscomplex(k)==0_${ik}$ ) then
! real eigenvector
ii = stdlib${ii}$_idamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$ ) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_dlacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if ! blocked back-transform
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
end do loop_140
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! for complex left vector, uses iv for real part and iv+1 for complex part.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb-1 or nb.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 1_${ik}$
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==1_${ik}$ ) then
! previous iteration (ki-1) was first of conjugate pair,
! so this ki is second of conjugate pair; skip to end of loop
ip = -1_${ik}$
cycle loop_260
else if( ki==n ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki+1, ki )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is first of conjugate pair
ip = 1_${ik}$
end if
if( somev ) then
if( .not.select( ki ) )cycle loop_260
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real left eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -t( ki, k )
end do
! solve transposed quasi-triangular system:
! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
! solve [ t(j,j) - wr ]**t * x = work
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+iv*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j+1 )&
, 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ )
! solve
! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 )
! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_dcopy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_dgemv( 'N', n, n-ki, one,vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 + iv*n ), 1_${ik}$,work( ki + iv*n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_idamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex left eigenvector.
! initial solve:
! [ ( t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi) ]*x = 0.
! [ ( t(ki+1,ki) t(ki+1,ki+1) ) ]
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki + (iv )*n ) = wi / t( ki, ki+1 )
work( ki+1 + (iv+1)*n ) = one
else
work( ki + (iv )*n ) = one
work( ki+1 + (iv+1)*n ) = -wi / t( ki+1, ki )
end if
work( ki+1 + (iv )*n ) = zero
work( ki + (iv+1)*n ) = zero
! form right-hand side.
do k = ki + 2, n
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(ki, k)
work( k+(iv+1)*n ) = -work( ki+1+(iv+1)*n )*t(ki+1,k)
end do
! solve transposed quasi-triangular system:
! [ t(ki+2:n,ki+2:n)**t - (wr-i*wi) ]*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j )&
, 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2,&
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2,&
j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+&
2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b
! [ (t(j+1,j) t(j+1,j+1)) ]
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ),vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_dcopy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n-1 ) then
call stdlib${ii}$_dgemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv)*n ), 1_${ik}$,work( ki + (iv)*n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv+1)*n ), 1_${ik}$,work( ki+1 + (iv+1)*n ),vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_dscal( n, work(ki+ (iv )*n), vl(1_${ik}$, ki ), 1_${ik}$)
call stdlib${ii}$_dscal( n, work(ki+1+(iv+1)*n), vl(1_${ik}$, ki+1), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + (iv )*n ) = zero
work( k + (iv+1)*n ) = zero
end do
iscomplex( iv ) = ip
iscomplex( iv+1 ) = -ip
iv = iv + 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki and ki+1)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki + 1_${ik}$
end if
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv>=nb-1) .or. (ki2==n) ) then
call stdlib${ii}$_dgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,&
work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
if( iscomplex(k)==0_${ik}$) then
! real eigenvector
ii = stdlib${ii}$_idamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_dlacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if ! blocked back-transform
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_dtrevc3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$trevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m, &
!! DTREVC3: computes some or all of the right and/or left eigenvectors of
!! a real upper quasi-triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**T)*T = w*(y**T)
!! where y**T denotes the transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal blocks of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the orthogonal factor that reduces a matrix
!! A to Schur form T, then Q*X and Q*Y are the matrices of right and
!! left eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, mm, n
! Array Arguments
logical(lk), intent(inout) :: select(*)
real(${rk}$), intent(in) :: t(ldt,*)
real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, pair, rightv, somev
integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, iv, maxwrk, nb, &
ki2
real(${rk}$) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, &
vcrit, vmax, wi, wr, xnorm
! Intrinsic Functions
! Local Arrays
real(${rk}$) :: x(2_${ik}$,2_${ik}$)
integer(${ik}$) :: iscomplex(nbmax)
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DTREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
lquery = ( lwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( lwork<max( 1_${ik}$, 3_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else
! set m to the number of columns required to store the selected
! eigenvectors, standardize the array select if necessary, and
! test mm.
if( somev ) then
m = 0_${ik}$
pair = .false.
do j = 1, n
if( pair ) then
pair = .false.
select( j ) = .false.
else
if( j<n ) then
if( t( j+1, j )==zero ) then
if( select( j ) )m = m + 1_${ik}$
else
pair = .true.
if( select( j ) .or. select( j+1 ) ) then
select( j ) = .true.
m = m + 2_${ik}$
end if
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_${ri}$laset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_${ri}$labad( unfl, ovfl )
ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
bignum = ( one-ulp ) / smlnum
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
work( 1_${ik}$ ) = zero
do j = 2, n
work( j ) = zero
do i = 1, j - 1
work( j ) = work( j ) + abs( t( i, j ) )
end do
end do
! index ip is used to specify the real or complex eigenvalue:
! ip = 0, real eigenvalue,
! 1, first of conjugate complex pair: (wr,wi)
! -1, second of conjugate complex pair: (wr,wi)
! iscomplex array stores ip for each column in current block.
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! for complex right vector, uses iv-1 for real part and iv for complex part.
! non-blocked version always uses iv=2;
! blocked version starts with iv=nb, goes down to 1 or 2.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 2_${ik}$
if( nb>2_${ik}$ ) then
iv = nb
end if
ip = 0_${ik}$
is = m
loop_140: do ki = n, 1, -1
if( ip==-1_${ik}$ ) then
! previous iteration (ki+1) was second of conjugate pair,
! so this ki is first of conjugate pair; skip to end of loop
ip = 1_${ik}$
cycle loop_140
else if( ki==1_${ik}$ ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki, ki-1 )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is second of conjugate pair
ip = -1_${ik}$
end if
if( somev ) then
if( ip==0_${ik}$ ) then
if( .not.select( ki ) )cycle loop_140
else
if( .not.select( ki-1 ) )cycle loop_140
end if
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real right eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work.
jnxt = ki - 1_${ik}$
loop_60: do j = ki - 1, 1, -1
if( j>jnxt )cycle loop_60
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr )
! scale x(1,1) and x(2,1) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ )
work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ )
! update right-hand side
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ )
end if
end do loop_60
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / abs( vr( ii, is ) )
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), &
1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vr( ii, ki ) )
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex right eigenvector.
! initial solve
! [ ( t(ki-1,ki-1) t(ki-1,ki) ) - (wr + i*wi) ]*x = 0.
! [ ( t(ki, ki-1) t(ki, ki) ) ]
if( abs( t( ki-1, ki ) )>=abs( t( ki, ki-1 ) ) ) then
work( ki-1 + (iv-1)*n ) = one
work( ki + (iv )*n ) = wi / t( ki-1, ki )
else
work( ki-1 + (iv-1)*n ) = -wi / t( ki, ki-1 )
work( ki + (iv )*n ) = one
end if
work( ki + (iv-1)*n ) = zero
work( ki-1 + (iv )*n ) = zero
! form right-hand side.
do k = 1, ki - 2
work( k+(iv-1)*n ) = -work( ki-1+(iv-1)*n )*t(k,ki-1)
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(k,ki )
end do
! solve upper quasi-triangular system:
! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2)
jnxt = ki - 2_${ik}$
loop_90: do j = ki - 2, 1, -1
if( j>jnxt )cycle loop_90
j1 = j
j2 = j
jnxt = j - 1_${ik}$
if( j>1_${ik}$ ) then
if( t( j, j-1 )/=zero ) then
j1 = j - 1_${ik}$
jnxt = j - 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale x(1,1) and x(1,2) to avoid overflow when
! updating the right-hand side.
if( xnorm>one ) then
if( work( j )>bignum / xnorm ) then
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm
scale = scale / xnorm
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
else
! 2-by-2 diagonal block
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, &
one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr )
! scale x to avoid overflow when updating
! the right-hand side.
if( xnorm>one ) then
beta = max( work( j-1 ), work( j ) )
if( beta>bignum / xnorm ) then
rec = one / xnorm
x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec
x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec
x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec
x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec
scale = scale*rec
end if
end if
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ )
! update the right-hand side
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),&
1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), &
1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), &
1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ )
end if
end do loop_90
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ )
emax = zero
do k = 1, ki
emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is-1 ) = zero
vr( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>2_${ik}$ ) then
call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), &
1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,&
work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$scal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$)
call stdlib${ii}$_${ri}$scal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + (iv-1)*n ) = zero
work( k + (iv )*n ) = zero
end do
iscomplex( iv-1 ) = -ip
iscomplex( iv ) = ip
iv = iv - 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki-1 and ki)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki - 1_${ik}$
end if
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
if( iscomplex(k)==0_${ik}$ ) then
! real eigenvector
ii = stdlib${ii}$_i${ri}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$ ) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_${ri}$scal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$lacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if ! blocked back-transform
is = is - 1_${ik}$
if( ip/=0_${ik}$ )is = is - 1_${ik}$
end do loop_140
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! for complex left vector, uses iv for real part and iv+1 for complex part.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb-1 or nb.
! (note the "0-th" column is used for 1-norms computed above.)
iv = 1_${ik}$
ip = 0_${ik}$
is = 1_${ik}$
loop_260: do ki = 1, n
if( ip==1_${ik}$ ) then
! previous iteration (ki-1) was first of conjugate pair,
! so this ki is second of conjugate pair; skip to end of loop
ip = -1_${ik}$
cycle loop_260
else if( ki==n ) then
! last column, so this ki must be real eigenvalue
ip = 0_${ik}$
else if( t( ki+1, ki )==zero ) then
! zero on sub-diagonal, so this ki is real eigenvalue
ip = 0_${ik}$
else
! non-zero on sub-diagonal, so this ki is first of conjugate pair
ip = 1_${ik}$
end if
if( somev ) then
if( .not.select( ki ) )cycle loop_260
end if
! compute the ki-th eigenvalue (wr,wi).
wr = t( ki, ki )
wi = zero
if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) )
smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
if( ip==0_${ik}$ ) then
! --------------------------------------------------------
! real left eigenvector
work( ki + iv*n ) = one
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -t( ki, k )
end do
! solve transposed quasi-triangular system:
! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work
vmax = one
vcrit = bignum
jnxt = ki + 1_${ik}$
loop_170: do j = ki + 1, n
if( j<jnxt )cycle loop_170
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
! solve [ t(j,j) - wr ]**t * x = work
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j+iv*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,&
work( ki+1+iv*n ), 1_${ik}$ )
work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j+1 )&
, 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ )
! solve
! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 )
! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ )
work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ )
vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax )
vcrit = bignum / vmax
end if
end do loop_170
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / abs( vl( ii, is ) )
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki, one,vl( 1_${ik}$, ki+1 ), ldvl,work( &
ki+1 + iv*n ), 1_${ik}$,work( ki + iv*n ), vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ri}$amax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / abs( vl( ii, ki ) )
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = zero
end do
iscomplex( iv ) = ip
! back-transform and normalization is done below
end if
else
! --------------------------------------------------------
! complex left eigenvector.
! initial solve:
! [ ( t(ki,ki) t(ki,ki+1) )**t - (wr - i* wi) ]*x = 0.
! [ ( t(ki+1,ki) t(ki+1,ki+1) ) ]
if( abs( t( ki, ki+1 ) )>=abs( t( ki+1, ki ) ) ) then
work( ki + (iv )*n ) = wi / t( ki, ki+1 )
work( ki+1 + (iv+1)*n ) = one
else
work( ki + (iv )*n ) = one
work( ki+1 + (iv+1)*n ) = -wi / t( ki+1, ki )
end if
work( ki+1 + (iv )*n ) = zero
work( ki + (iv+1)*n ) = zero
! form right-hand side.
do k = ki + 2, n
work( k+(iv )*n ) = -work( ki +(iv )*n )*t(ki, k)
work( k+(iv+1)*n ) = -work( ki+1+(iv+1)*n )*t(ki+1,k)
end do
! solve transposed quasi-triangular system:
! [ t(ki+2:n,ki+2:n)**t - (wr-i*wi) ]*x = work1+i*work2
vmax = one
vcrit = bignum
jnxt = ki + 2_${ik}$
loop_200: do j = ki + 2, n
if( j<jnxt )cycle loop_200
j1 = j
j2 = j
jnxt = j + 1_${ik}$
if( j<n ) then
if( t( j+1, j )/=zero ) then
j2 = j + 1_${ik}$
jnxt = j + 2_${ik}$
end if
end if
if( j1==j2 ) then
! 1-by-1 diagonal block
! scale if necessary to avoid overflow when
! forming the right-hand side elements.
if( work( j )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j )&
, 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2
call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax )
vcrit = bignum / vmax
else
! 2-by-2 diagonal block
! scale if necessary to avoid overflow when forming
! the right-hand side elements.
beta = max( work( j ), work( j+1 ) )
if( beta>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ )
vmax = one
vcrit = bignum
end if
work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, &
j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2,&
j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2,&
j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ )
work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+&
2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ )
! solve 2-by-2 complex linear equation
! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b
! [ (t(j+1,j) t(j+1,j+1)) ]
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, &
work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr )
! scale if necessary
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$)
call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$)
end if
work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ )
work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ )
work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ )
work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ )
vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(&
2_${ik}$, 2_${ik}$ ) ),vmax )
vcrit = bignum / vmax
end if
end do loop_200
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ )
emax = zero
do k = ki, n
emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = zero
vl( k, is+1 ) = zero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n-1 ) then
call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv)*n ), 1_${ik}$,work( ki + (iv)*n ),vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'N', n, n-ki-1, one,vl( 1_${ik}$, ki+2 ), ldvl,work( ki+2 + &
(iv+1)*n ), 1_${ik}$,work( ki+1 + (iv+1)*n ),vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$scal( n, work(ki+ (iv )*n), vl(1_${ik}$, ki ), 1_${ik}$)
call stdlib${ii}$_${ri}$scal( n, work(ki+1+(iv+1)*n), vl(1_${ik}$, ki+1), 1_${ik}$)
end if
emax = zero
do k = 1, n
emax = max( emax, abs( vl( k, ki ) )+abs( vl( k, ki+1 ) ) )
end do
remax = one / emax
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, remax, vl( 1_${ik}$, ki+1 ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + (iv )*n ) = zero
work( k + (iv+1)*n ) = zero
end do
iscomplex( iv ) = ip
iscomplex( iv+1 ) = -ip
iv = iv + 1_${ik}$
! back-transform and normalization is done below
end if
end if
if( nb>1_${ik}$ ) then
! --------------------------------------------------------
! blocked version of back-transform
! for complex case, ki2 includes both vectors (ki and ki+1)
if( ip==0_${ik}$ ) then
ki2 = ki
else
ki2 = ki + 1_${ik}$
end if
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb-1 or nb,
! or if this was last vector, do the gemm
if( (iv>=nb-1) .or. (ki2==n) ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,&
work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
if( iscomplex(k)==0_${ik}$) then
! real eigenvector
ii = stdlib${ii}$_i${ri}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / abs( work( ii + (nb+k)*n ) )
else if( iscomplex(k)==1_${ik}$) then
! first eigenvector of conjugate pair
emax = zero
do ii = 1, n
emax = max( emax,abs( work( ii + (nb+k )*n ) )+abs( work( ii + (&
nb+k+1)*n ) ) )
end do
remax = one / emax
! else if iscomplex(k)==-1
! second eigenvector of conjugate pair
! reuse same remax as previous k
end if
call stdlib${ii}$_${ri}$scal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$lacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if ! blocked back-transform
is = is + 1_${ik}$
if( ip/=0_${ik}$ )is = is + 1_${ik}$
end do loop_260
end if
return
end subroutine stdlib${ii}$_${ri}$trevc3
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! CTREVC3 computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, rwork, lrwork, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, lrwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki, iv, maxwrk, nb
real(sp) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(sp) :: cdum
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CTREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
rwork(1_${ik}$) = n
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else if ( lrwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_claset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_slabad( unfl, ovfl )
ulp = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_scasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=nb=1;
! blocked version starts with iv=nb, goes down to 1.
! (note the "0-th" column is used to store the original diagonal.)
iv = nb
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex right eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper triangular system:
! [ t(1:ki-1,1:ki-1) - t(ki,ki) ]*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ + iv*n ), scale,rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_ccopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_csscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_cgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,&
cmplx( scale,KIND=sp),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_csscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = czero
end do
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then
call stdlib${ii}$_cgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
ii = stdlib${ii}$_icamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_csscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_clacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb.
! (note the "0-th" column is used to store the original diagonal.)
iv = 1_${ik}$
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex left eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -conjg( t( ki, k ) )
end do
! solve conjugate-transposed triangular system:
! [ t(ki+1:n,ki+1:n) - t(ki,ki) ]**h * x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 + iv*n ), scale, rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_ccopy( n-ki+1, work( ki + iv*n ), 1_${ik}$, vl(ki,is), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_csscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_cgemv( 'N', n, n-ki, cone, vl( 1_${ik}$, ki+1 ), ldvl,work( ki+&
1_${ik}$ + iv*n ), 1_${ik}$, cmplx( scale,KIND=sp),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_icamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_csscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = czero
end do
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==nb) .or. (ki==n) ) then
call stdlib${ii}$_cgemm( 'N', 'N', n, iv, n-ki+iv, cone,vl( 1_${ik}$, ki-iv+1 ), ldvl,&
work( ki-iv+1 + (1_${ik}$)*n ), n,czero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
ii = stdlib${ii}$_icamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_csscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_clacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_ctrevc3
pure module subroutine stdlib${ii}$_ztrevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! ZTREVC3 computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, rwork, lrwork, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, lrwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki, iv, maxwrk, nb
real(dp) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(dp) :: cdum
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
rwork(1_${ik}$) = n
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else if ( lrwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_zlaset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_dlabad( unfl, ovfl )
ulp = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_dzasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=nb=1;
! blocked version starts with iv=nb, goes down to 1.
! (note the "0-th" column is used to store the original diagonal.)
iv = nb
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex right eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper triangular system:
! [ t(1:ki-1,1:ki-1) - t(ki,ki) ]*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ + iv*n ), scale,rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_zcopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_zdscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_zgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,&
cmplx( scale,KIND=dp),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_zdscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = czero
end do
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then
call stdlib${ii}$_zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
ii = stdlib${ii}$_izamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_zdscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_zlacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb.
! (note the "0-th" column is used to store the original diagonal.)
iv = 1_${ik}$
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex left eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -conjg( t( ki, k ) )
end do
! solve conjugate-transposed triangular system:
! [ t(ki+1:n,ki+1:n) - t(ki,ki) ]**h * x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 + iv*n ), scale, rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_zcopy( n-ki+1, work( ki + iv*n ), 1_${ik}$, vl(ki,is), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_zdscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_zgemv( 'N', n, n-ki, cone, vl( 1_${ik}$, ki+1 ), ldvl,work( ki+&
1_${ik}$ + iv*n ), 1_${ik}$, cmplx( scale,KIND=dp),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_izamax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_zdscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = czero
end do
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==nb) .or. (ki==n) ) then
call stdlib${ii}$_zgemm( 'N', 'N', n, iv, n-ki+iv, cone,vl( 1_${ik}$, ki-iv+1 ), ldvl,&
work( ki-iv+1 + (1_${ik}$)*n ), n,czero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
ii = stdlib${ii}$_izamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_zdscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_zlacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_ztrevc3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, &
!! ZTREVC3: computes some or all of the right and/or left eigenvectors of
!! a complex upper triangular matrix T.
!! Matrices of this type are produced by the Schur factorization of
!! a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
!! The right eigenvector x and the left eigenvector y of T corresponding
!! to an eigenvalue w are defined by:
!! T*x = w*x, (y**H)*T = w*(y**H)
!! where y**H denotes the conjugate transpose of the vector y.
!! The eigenvalues are not input to this routine, but are read directly
!! from the diagonal of T.
!! This routine returns the matrices X and/or Y of right and left
!! eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!! input matrix. If Q is the unitary factor that reduces a matrix A to
!! Schur form T, then Q*X and Q*Y are the matrices of right and left
!! eigenvectors of A.
!! This uses a Level 3 BLAS version of the back transformation.
work, lwork, rwork, lrwork, 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) :: howmny, side
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, lwork, lrwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: nbmin = 8_${ik}$
integer(${ik}$), parameter :: nbmax = 128_${ik}$
! Local Scalars
logical(lk) :: allv, bothv, leftv, lquery, over, rightv, somev
integer(${ik}$) :: i, ii, is, j, k, ki, iv, maxwrk, nb
real(${ck}$) :: ovfl, remax, scale, smin, smlnum, ulp, unfl
complex(${ck}$) :: cdum
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
bothv = stdlib_lsame( side, 'B' )
rightv = stdlib_lsame( side, 'R' ) .or. bothv
leftv = stdlib_lsame( side, 'L' ) .or. bothv
allv = stdlib_lsame( howmny, 'A' )
over = stdlib_lsame( howmny, 'B' )
somev = stdlib_lsame( howmny, 'S' )
! set m to the number of columns required to store the selected
! eigenvectors.
if( somev ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTREVC', side // howmny, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
maxwrk = n + 2_${ik}$*n*nb
work(1_${ik}$) = maxwrk
rwork(1_${ik}$) = n
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ )
if( .not.rightv .and. .not.leftv ) then
info = -1_${ik}$
else if( .not.allv .and. .not.over .and. .not.somev ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( leftv .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( rightv .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -11_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -14_${ik}$
else if ( lrwork<max( 1_${ik}$, n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREVC3', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( n==0 )return
! use blocked version of back-transformation if sufficient workspace.
! zero-out the workspace to avoid potential nan propagation.
if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then
nb = (lwork - n) / (2_${ik}$*n)
nb = min( nb, nbmax )
call stdlib${ii}$_${ci}$laset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n )
else
nb = 1_${ik}$
end if
! set the constants to control overflow.
unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
ovfl = one / unfl
call stdlib${ii}$_${c2ri(ci)}$labad( unfl, ovfl )
ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = unfl*( n / ulp )
! store the diagonal elements of t in working array work.
do i = 1, n
work( i ) = t( i, i )
end do
! compute 1-norm of each column of strictly upper triangular
! part of t to control overflow in triangular solver.
rwork( 1_${ik}$ ) = zero
do j = 2, n
rwork( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ )
end do
if( rightv ) then
! ============================================================
! compute right eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=nb=1;
! blocked version starts with iv=nb, goes down to 1.
! (note the "0-th" column is used to store the original diagonal.)
iv = nb
is = m
loop_80: do ki = n, 1, -1
if( somev ) then
if( .not.select( ki ) )cycle loop_80
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex right eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = 1, ki - 1
work( k + iv*n ) = -t( k, ki )
end do
! solve upper triangular system:
! [ t(1:ki-1,1:ki-1) - t(ki,ki) ]*x = scale*work.
do k = 1, ki - 1
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki>1_${ik}$ ) then
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, &
work( 1_${ik}$ + iv*n ), scale,rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vr and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vr and normalize.
call stdlib${ii}$_${ci}$copy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ )
remax = one / cabs1( vr( ii, is ) )
call stdlib${ii}$_${ci}$dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ )
do k = ki + 1, n
vr( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,&
cmplx( scale,KIND=${ck}$),vr( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vr( ii, ki ) )
call stdlib${ii}$_${ci}$dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out below vector
do k = ki + 1, n
work( k + iv*n ) = czero
end do
! columns iv:nb of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then
call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + &
(iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n )
! normalize vectors
do k = iv, nb
ii = stdlib${ii}$_i${ci}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_${ci}$dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_${ci}$lacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), &
ldvr )
iv = nb
else
iv = iv - 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = 1, ki - 1
t( k, k ) = work( k )
end do
is = is - 1_${ik}$
end do loop_80
end if
if( leftv ) then
! ============================================================
! compute left eigenvectors.
! iv is index of column in current block.
! non-blocked version always uses iv=1;
! blocked version starts with iv=1, goes up to nb.
! (note the "0-th" column is used to store the original diagonal.)
iv = 1_${ik}$
is = 1_${ik}$
loop_130: do ki = 1, n
if( somev ) then
if( .not.select( ki ) )cycle loop_130
end if
smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
! --------------------------------------------------------
! complex left eigenvector
work( ki + iv*n ) = cone
! form right-hand side.
do k = ki + 1, n
work( k + iv*n ) = -conjg( t( ki, k ) )
end do
! solve conjugate-transposed triangular system:
! [ t(ki+1:n,ki+1:n) - t(ki,ki) ]**h * x = scale*work.
do k = ki + 1, n
t( k, k ) = t( k, k ) - t( ki, ki )
if( cabs1( t( k, k ) )<smin )t( k, k ) = smin
end do
if( ki<n ) then
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT','Y', n-ki, t( &
ki+1, ki+1 ), ldt,work( ki+1 + iv*n ), scale, rwork, info )
work( ki + iv*n ) = scale
end if
! copy the vector x or q*x to vl and normalize.
if( .not.over ) then
! ------------------------------
! no back-transform: copy x to vl and normalize.
call stdlib${ii}$_${ci}$copy( n-ki+1, work( ki + iv*n ), 1_${ik}$, vl(ki,is), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$
remax = one / cabs1( vl( ii, is ) )
call stdlib${ii}$_${ci}$dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ )
do k = 1, ki - 1
vl( k, is ) = czero
end do
else if( nb==1_${ik}$ ) then
! ------------------------------
! version 1: back-transform each vector with gemv, q*x.
if( ki<n )call stdlib${ii}$_${ci}$gemv( 'N', n, n-ki, cone, vl( 1_${ik}$, ki+1 ), ldvl,work( ki+&
1_${ik}$ + iv*n ), 1_${ik}$, cmplx( scale,KIND=${ck}$),vl( 1_${ik}$, ki ), 1_${ik}$ )
ii = stdlib${ii}$_i${ci}$amax( n, vl( 1_${ik}$, ki ), 1_${ik}$ )
remax = one / cabs1( vl( ii, ki ) )
call stdlib${ii}$_${ci}$dscal( n, remax, vl( 1_${ik}$, ki ), 1_${ik}$ )
else
! ------------------------------
! version 2: back-transform block of vectors with gemm
! zero out above vector
! could go from ki-nv+1 to ki-1
do k = 1, ki - 1
work( k + iv*n ) = czero
end do
! columns 1:iv of work are valid vectors.
! when the number of vectors stored reaches nb,
! or if this was last vector, do the gemm
if( (iv==nb) .or. (ki==n) ) then
call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, iv, n-ki+iv, cone,vl( 1_${ik}$, ki-iv+1 ), ldvl,&
work( ki-iv+1 + (1_${ik}$)*n ), n,czero,work( 1_${ik}$ + (nb+1)*n ), n )
! normalize vectors
do k = 1, iv
ii = stdlib${ii}$_i${ci}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
remax = one / cabs1( work( ii + (nb+k)*n ) )
call stdlib${ii}$_${ci}$dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ )
end do
call stdlib${ii}$_${ci}$lacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki-iv+1 ), &
ldvl )
iv = 1_${ik}$
else
iv = iv + 1_${ik}$
end if
end if
! restore the original diagonal elements of t.
do k = ki + 1, n
t( k, k ) = work( k )
end do
is = is + 1_${ik}$
end do loop_130
end if
return
end subroutine stdlib${ii}$_${ci}$trevc3
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, &
!! SLALN2 solves a system of the form (ca A - w D ) X = s B
!! or (ca A**T - w D) X = s B with possible scaling ("s") and
!! perturbation of A. (A**T means A-transpose.)
!! A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!! real diagonal matrix, w is a real or complex value, and X and B are
!! NA x 1 matrices -- real if w is real, complex if w is complex. NA
!! may be 1 or 2.
!! If w is complex, X and B are represented as NA x 2 matrices,
!! the first column of each being the real part and the second
!! being the imaginary part.
!! "s" is a scaling factor (<= 1), computed by SLALN2, which is
!! so chosen that X can be computed without overflow. X is further
!! scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!! than overflow.
!! If both singular values of (ca A - w D) are less than SMIN,
!! SMIN*identity will be used instead of (ca A - w D). If only one
!! singular value is less than SMIN, one element of (ca A - w D) will be
!! perturbed enough to make the smallest singular value roughly SMIN.
!! If both singular values are at least SMIN, (ca A - w D) will not be
!! perturbed. In any case, the perturbation will be at most some small
!! multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
!! are computed by infinity-norm approximations, and thus will only be
!! correct to a factor of 2 or so.
!! Note: all input quantities are assumed to be smaller than overflow
!! by a reasonable factor. (See BIGNUM.)
ldx, scale, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltrans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw
real(sp), intent(in) :: ca, d1, d2, smin, wi, wr
real(sp), intent(out) :: scale, xnorm
! Array Arguments
real(sp), intent(in) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: icmax, j
real(sp) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, &
cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, &
ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2
! Local Arrays
logical(lk) :: cswap(4_${ik}$), rswap(4_${ik}$)
integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$)
real(sp) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$)
! Intrinsic Functions
! Equivalences
equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) )
! Data Statements
cswap = [.false.,.false.,.true.,.true.]
rswap = [.false.,.true.,.false.,.true.]
ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$])
! Executable Statements
! compute bignum
smlnum = two*stdlib${ii}$_slamch( 'SAFE MINIMUM' )
bignum = one / smlnum
smini = max( smin, smlnum )
! don't check for input errors
info = 0_${ik}$
! standard initializations
scale = one
if( na==1_${ik}$ ) then
! 1 x 1 (i.e., scalar) system c x = b
if( nw==1_${ik}$ ) then
! real 1x1 system.
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cnorm = abs( csr )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
else
! complex 1x1 system (w is complex)
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
csi = -wi*d1
cnorm = abs( csr ) + abs( csi )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
csi = zero
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
call stdlib${ii}$_sladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, &
2_${ik}$ ) )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
end if
else
! 2x2 system
! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=sp)
cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2
if( ltrans ) then
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
else
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
end if
if( nw==1_${ik}$ ) then
! real2x2 system (w is real,KIND=sp)
! find the largest element in c
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )>cmax ) then
cmax = abs( crv( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 2_${ik}$, 1_${ik}$ ) ) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ur11r = one / ur11
lr21 = ur11r*cr21
ur22 = cr22 - ur12*lr21
! if smaller pivot < smini, use smini
if( abs( ur22 )<smini ) then
ur22 = smini
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br1 = b( 2_${ik}$, 1_${ik}$ )
br2 = b( 1_${ik}$, 1_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
end if
br2 = br2 - lr21*br1
bbnd = max( abs( br1*( ur22*ur11r ) ), abs( br2 ) )
if( bbnd>one .and. abs( ur22 )<one ) then
if( bbnd>=bignum*abs( ur22 ) )scale = one / bbnd
end if
xr2 = ( br2*scale ) / ur22
xr1 = ( scale*br1 )*ur11r - xr2*( ur11r*ur12 )
if( cswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
end if
xnorm = max( abs( xr1 ), abs( xr2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
else
! complex 2x2 system (w is complex)
! find the largest element in c
ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1
ci( 2_${ik}$, 1_${ik}$ ) = zero
ci( 1_${ik}$, 2_${ik}$ ) = zero
ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then
cmax = abs( crv( j ) ) + abs( civ( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ )&
) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
ui11 = civ( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ci21 = civ( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
ui12 = civ( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ci22 = civ( ipivot( 4_${ik}$, icmax ) )
if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then
! code when off-diagonals of pivoted c are real
if( abs( ur11 )>abs( ui11 ) ) then
temp = ui11 / ur11
ur11r = one / ( ur11*( one+temp**2_${ik}$ ) )
ui11r = -temp*ur11r
else
temp = ur11 / ui11
ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) )
ur11r = -temp*ui11r
end if
lr21 = cr21*ur11r
li21 = cr21*ui11r
ur12s = ur12*ur11r
ui12s = ur12*ui11r
ur22 = cr22 - ur12*lr21
ui22 = ci22 - ur12*li21
else
! code when diagonals of pivoted c are real
ur11r = one / ur11
ui11r = zero
lr21 = cr21*ur11r
li21 = ci21*ur11r
ur12s = ur12*ur11r
ui12s = ui12*ur11r
ur22 = cr22 - ur12*lr21 + ui12*li21
ui22 = -ur12*li21 - ui12*lr21
end if
u22abs = abs( ur22 ) + abs( ui22 )
! if smaller pivot < smini, use smini
if( u22abs<smini ) then
ur22 = smini
ui22 = zero
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br2 = b( 1_${ik}$, 1_${ik}$ )
br1 = b( 2_${ik}$, 1_${ik}$ )
bi2 = b( 1_${ik}$, 2_${ik}$ )
bi1 = b( 2_${ik}$, 2_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
bi1 = b( 1_${ik}$, 2_${ik}$ )
bi2 = b( 2_${ik}$, 2_${ik}$ )
end if
br2 = br2 - lr21*br1 + li21*bi1
bi2 = bi2 - li21*br1 - lr21*bi1
bbnd = max( ( abs( br1 )+abs( bi1 ) )*( u22abs*( abs( ur11r )+abs( ui11r ) ) ),&
abs( br2 )+abs( bi2 ) )
if( bbnd>one .and. u22abs<one ) then
if( bbnd>=bignum*u22abs ) then
scale = one / bbnd
br1 = scale*br1
bi1 = scale*bi1
br2 = scale*br2
bi2 = scale*bi2
end if
end if
call stdlib${ii}$_sladiv( br2, bi2, ur22, ui22, xr2, xi2 )
xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2
xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2
if( cswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
x( 1_${ik}$, 2_${ik}$ ) = xi2
x( 2_${ik}$, 2_${ik}$ ) = xi1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
x( 1_${ik}$, 2_${ik}$ ) = xi1
x( 2_${ik}$, 2_${ik}$ ) = xi2
end if
xnorm = max( abs( xr1 )+abs( xi1 ), abs( xr2 )+abs( xi2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
end if
end if
return
end subroutine stdlib${ii}$_slaln2
pure module subroutine stdlib${ii}$_dlaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, &
!! DLALN2 solves a system of the form (ca A - w D ) X = s B
!! or (ca A**T - w D) X = s B with possible scaling ("s") and
!! perturbation of A. (A**T means A-transpose.)
!! A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!! real diagonal matrix, w is a real or complex value, and X and B are
!! NA x 1 matrices -- real if w is real, complex if w is complex. NA
!! may be 1 or 2.
!! If w is complex, X and B are represented as NA x 2 matrices,
!! the first column of each being the real part and the second
!! being the imaginary part.
!! "s" is a scaling factor (<= 1), computed by DLALN2, which is
!! so chosen that X can be computed without overflow. X is further
!! scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!! than overflow.
!! If both singular values of (ca A - w D) are less than SMIN,
!! SMIN*identity will be used instead of (ca A - w D). If only one
!! singular value is less than SMIN, one element of (ca A - w D) will be
!! perturbed enough to make the smallest singular value roughly SMIN.
!! If both singular values are at least SMIN, (ca A - w D) will not be
!! perturbed. In any case, the perturbation will be at most some small
!! multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
!! are computed by infinity-norm approximations, and thus will only be
!! correct to a factor of 2 or so.
!! Note: all input quantities are assumed to be smaller than overflow
!! by a reasonable factor. (See BIGNUM.)
ldx, scale, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltrans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw
real(dp), intent(in) :: ca, d1, d2, smin, wi, wr
real(dp), intent(out) :: scale, xnorm
! Array Arguments
real(dp), intent(in) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: icmax, j
real(dp) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, &
cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, &
ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2
! Local Arrays
logical(lk) :: rswap(4_${ik}$), zswap(4_${ik}$)
integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$)
real(dp) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$)
! Intrinsic Functions
! Equivalences
equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) )
! Data Statements
zswap = [.false.,.false.,.true.,.true.]
rswap = [.false.,.true.,.false.,.true.]
ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$])
! Executable Statements
! compute bignum
smlnum = two*stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
bignum = one / smlnum
smini = max( smin, smlnum )
! don't check for input errors
info = 0_${ik}$
! standard initializations
scale = one
if( na==1_${ik}$ ) then
! 1 x 1 (i.e., scalar) system c x = b
if( nw==1_${ik}$ ) then
! real 1x1 system.
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cnorm = abs( csr )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
else
! complex 1x1 system (w is complex)
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
csi = -wi*d1
cnorm = abs( csr ) + abs( csi )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
csi = zero
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
call stdlib${ii}$_dladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, &
2_${ik}$ ) )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
end if
else
! 2x2 system
! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=dp)
cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2
if( ltrans ) then
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
else
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
end if
if( nw==1_${ik}$ ) then
! real2x2 system (w is real,KIND=dp)
! find the largest element in c
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )>cmax ) then
cmax = abs( crv( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 2_${ik}$, 1_${ik}$ ) ) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ur11r = one / ur11
lr21 = ur11r*cr21
ur22 = cr22 - ur12*lr21
! if smaller pivot < smini, use smini
if( abs( ur22 )<smini ) then
ur22 = smini
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br1 = b( 2_${ik}$, 1_${ik}$ )
br2 = b( 1_${ik}$, 1_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
end if
br2 = br2 - lr21*br1
bbnd = max( abs( br1*( ur22*ur11r ) ), abs( br2 ) )
if( bbnd>one .and. abs( ur22 )<one ) then
if( bbnd>=bignum*abs( ur22 ) )scale = one / bbnd
end if
xr2 = ( br2*scale ) / ur22
xr1 = ( scale*br1 )*ur11r - xr2*( ur11r*ur12 )
if( zswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
end if
xnorm = max( abs( xr1 ), abs( xr2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
else
! complex 2x2 system (w is complex)
! find the largest element in c
ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1
ci( 2_${ik}$, 1_${ik}$ ) = zero
ci( 1_${ik}$, 2_${ik}$ ) = zero
ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then
cmax = abs( crv( j ) ) + abs( civ( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ )&
) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
ui11 = civ( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ci21 = civ( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
ui12 = civ( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ci22 = civ( ipivot( 4_${ik}$, icmax ) )
if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then
! code when off-diagonals of pivoted c are real
if( abs( ur11 )>abs( ui11 ) ) then
temp = ui11 / ur11
ur11r = one / ( ur11*( one+temp**2_${ik}$ ) )
ui11r = -temp*ur11r
else
temp = ur11 / ui11
ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) )
ur11r = -temp*ui11r
end if
lr21 = cr21*ur11r
li21 = cr21*ui11r
ur12s = ur12*ur11r
ui12s = ur12*ui11r
ur22 = cr22 - ur12*lr21
ui22 = ci22 - ur12*li21
else
! code when diagonals of pivoted c are real
ur11r = one / ur11
ui11r = zero
lr21 = cr21*ur11r
li21 = ci21*ur11r
ur12s = ur12*ur11r
ui12s = ui12*ur11r
ur22 = cr22 - ur12*lr21 + ui12*li21
ui22 = -ur12*li21 - ui12*lr21
end if
u22abs = abs( ur22 ) + abs( ui22 )
! if smaller pivot < smini, use smini
if( u22abs<smini ) then
ur22 = smini
ui22 = zero
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br2 = b( 1_${ik}$, 1_${ik}$ )
br1 = b( 2_${ik}$, 1_${ik}$ )
bi2 = b( 1_${ik}$, 2_${ik}$ )
bi1 = b( 2_${ik}$, 2_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
bi1 = b( 1_${ik}$, 2_${ik}$ )
bi2 = b( 2_${ik}$, 2_${ik}$ )
end if
br2 = br2 - lr21*br1 + li21*bi1
bi2 = bi2 - li21*br1 - lr21*bi1
bbnd = max( ( abs( br1 )+abs( bi1 ) )*( u22abs*( abs( ur11r )+abs( ui11r ) ) ),&
abs( br2 )+abs( bi2 ) )
if( bbnd>one .and. u22abs<one ) then
if( bbnd>=bignum*u22abs ) then
scale = one / bbnd
br1 = scale*br1
bi1 = scale*bi1
br2 = scale*br2
bi2 = scale*bi2
end if
end if
call stdlib${ii}$_dladiv( br2, bi2, ur22, ui22, xr2, xi2 )
xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2
xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2
if( zswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
x( 1_${ik}$, 2_${ik}$ ) = xi2
x( 2_${ik}$, 2_${ik}$ ) = xi1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
x( 1_${ik}$, 2_${ik}$ ) = xi1
x( 2_${ik}$, 2_${ik}$ ) = xi2
end if
xnorm = max( abs( xr1 )+abs( xi1 ), abs( xr2 )+abs( xi2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
end if
end if
return
end subroutine stdlib${ii}$_dlaln2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, &
!! DLALN2: solves a system of the form (ca A - w D ) X = s B
!! or (ca A**T - w D) X = s B with possible scaling ("s") and
!! perturbation of A. (A**T means A-transpose.)
!! A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!! real diagonal matrix, w is a real or complex value, and X and B are
!! NA x 1 matrices -- real if w is real, complex if w is complex. NA
!! may be 1 or 2.
!! If w is complex, X and B are represented as NA x 2 matrices,
!! the first column of each being the real part and the second
!! being the imaginary part.
!! "s" is a scaling factor (<= 1), computed by DLALN2, which is
!! so chosen that X can be computed without overflow. X is further
!! scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!! than overflow.
!! If both singular values of (ca A - w D) are less than SMIN,
!! SMIN*identity will be used instead of (ca A - w D). If only one
!! singular value is less than SMIN, one element of (ca A - w D) will be
!! perturbed enough to make the smallest singular value roughly SMIN.
!! If both singular values are at least SMIN, (ca A - w D) will not be
!! perturbed. In any case, the perturbation will be at most some small
!! multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
!! are computed by infinity-norm approximations, and thus will only be
!! correct to a factor of 2 or so.
!! Note: all input quantities are assumed to be smaller than overflow
!! by a reasonable factor. (See BIGNUM.)
ldx, scale, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltrans
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw
real(${rk}$), intent(in) :: ca, d1, d2, smin, wi, wr
real(${rk}$), intent(out) :: scale, xnorm
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: icmax, j
real(${rk}$) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, &
cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, &
ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2
! Local Arrays
logical(lk) :: rswap(4_${ik}$), zswap(4_${ik}$)
integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$)
real(${rk}$) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$)
! Intrinsic Functions
! Equivalences
equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) )
! Data Statements
zswap = [.false.,.false.,.true.,.true.]
rswap = [.false.,.true.,.false.,.true.]
ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$])
! Executable Statements
! compute bignum
smlnum = two*stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
bignum = one / smlnum
smini = max( smin, smlnum )
! don't check for input errors
info = 0_${ik}$
! standard initializations
scale = one
if( na==1_${ik}$ ) then
! 1 x 1 (i.e., scalar) system c x = b
if( nw==1_${ik}$ ) then
! real 1x1 system.
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cnorm = abs( csr )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
else
! complex 1x1 system (w is complex)
! c = ca a - w d
csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
csi = -wi*d1
cnorm = abs( csr ) + abs( csi )
! if | c | < smini, use c = smini
if( cnorm<smini ) then
csr = smini
csi = zero
cnorm = smini
info = 1_${ik}$
end if
! check scaling for x = b / c
bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) )
if( cnorm<one .and. bnorm>one ) then
if( bnorm>bignum*cnorm )scale = one / bnorm
end if
! compute x
call stdlib${ii}$_${ri}$ladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, &
2_${ik}$ ) )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
end if
else
! 2x2 system
! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=${rk}$)
cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1
cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2
if( ltrans ) then
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
else
cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ )
cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ )
end if
if( nw==1_${ik}$ ) then
! real2x2 system (w is real,KIND=${rk}$)
! find the largest element in c
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )>cmax ) then
cmax = abs( crv( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 2_${ik}$, 1_${ik}$ ) ) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ur11r = one / ur11
lr21 = ur11r*cr21
ur22 = cr22 - ur12*lr21
! if smaller pivot < smini, use smini
if( abs( ur22 )<smini ) then
ur22 = smini
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br1 = b( 2_${ik}$, 1_${ik}$ )
br2 = b( 1_${ik}$, 1_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
end if
br2 = br2 - lr21*br1
bbnd = max( abs( br1*( ur22*ur11r ) ), abs( br2 ) )
if( bbnd>one .and. abs( ur22 )<one ) then
if( bbnd>=bignum*abs( ur22 ) )scale = one / bbnd
end if
xr2 = ( br2*scale ) / ur22
xr1 = ( scale*br1 )*ur11r - xr2*( ur11r*ur12 )
if( zswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
end if
xnorm = max( abs( xr1 ), abs( xr2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
else
! complex 2x2 system (w is complex)
! find the largest element in c
ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1
ci( 2_${ik}$, 1_${ik}$ ) = zero
ci( 1_${ik}$, 2_${ik}$ ) = zero
ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2
cmax = zero
icmax = 0_${ik}$
do j = 1, 4
if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then
cmax = abs( crv( j ) ) + abs( civ( j ) )
icmax = j
end if
end do
! if norm(c) < smini, use smini*identity.
if( cmax<smini ) then
bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ )&
) )
if( smini<one .and. bnorm>one ) then
if( bnorm>bignum*smini )scale = one / bnorm
end if
temp = scale / smini
x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ )
xnorm = temp*bnorm
info = 1_${ik}$
return
end if
! gaussian elimination with complete pivoting.
ur11 = crv( icmax )
ui11 = civ( icmax )
cr21 = crv( ipivot( 2_${ik}$, icmax ) )
ci21 = civ( ipivot( 2_${ik}$, icmax ) )
ur12 = crv( ipivot( 3_${ik}$, icmax ) )
ui12 = civ( ipivot( 3_${ik}$, icmax ) )
cr22 = crv( ipivot( 4_${ik}$, icmax ) )
ci22 = civ( ipivot( 4_${ik}$, icmax ) )
if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then
! code when off-diagonals of pivoted c are real
if( abs( ur11 )>abs( ui11 ) ) then
temp = ui11 / ur11
ur11r = one / ( ur11*( one+temp**2_${ik}$ ) )
ui11r = -temp*ur11r
else
temp = ur11 / ui11
ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) )
ur11r = -temp*ui11r
end if
lr21 = cr21*ur11r
li21 = cr21*ui11r
ur12s = ur12*ur11r
ui12s = ur12*ui11r
ur22 = cr22 - ur12*lr21
ui22 = ci22 - ur12*li21
else
! code when diagonals of pivoted c are real
ur11r = one / ur11
ui11r = zero
lr21 = cr21*ur11r
li21 = ci21*ur11r
ur12s = ur12*ur11r
ui12s = ui12*ur11r
ur22 = cr22 - ur12*lr21 + ui12*li21
ui22 = -ur12*li21 - ui12*lr21
end if
u22abs = abs( ur22 ) + abs( ui22 )
! if smaller pivot < smini, use smini
if( u22abs<smini ) then
ur22 = smini
ui22 = zero
info = 1_${ik}$
end if
if( rswap( icmax ) ) then
br2 = b( 1_${ik}$, 1_${ik}$ )
br1 = b( 2_${ik}$, 1_${ik}$ )
bi2 = b( 1_${ik}$, 2_${ik}$ )
bi1 = b( 2_${ik}$, 2_${ik}$ )
else
br1 = b( 1_${ik}$, 1_${ik}$ )
br2 = b( 2_${ik}$, 1_${ik}$ )
bi1 = b( 1_${ik}$, 2_${ik}$ )
bi2 = b( 2_${ik}$, 2_${ik}$ )
end if
br2 = br2 - lr21*br1 + li21*bi1
bi2 = bi2 - li21*br1 - lr21*bi1
bbnd = max( ( abs( br1 )+abs( bi1 ) )*( u22abs*( abs( ur11r )+abs( ui11r ) ) ),&
abs( br2 )+abs( bi2 ) )
if( bbnd>one .and. u22abs<one ) then
if( bbnd>=bignum*u22abs ) then
scale = one / bbnd
br1 = scale*br1
bi1 = scale*bi1
br2 = scale*br2
bi2 = scale*bi2
end if
end if
call stdlib${ii}$_${ri}$ladiv( br2, bi2, ur22, ui22, xr2, xi2 )
xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2
xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2
if( zswap( icmax ) ) then
x( 1_${ik}$, 1_${ik}$ ) = xr2
x( 2_${ik}$, 1_${ik}$ ) = xr1
x( 1_${ik}$, 2_${ik}$ ) = xi2
x( 2_${ik}$, 2_${ik}$ ) = xi1
else
x( 1_${ik}$, 1_${ik}$ ) = xr1
x( 2_${ik}$, 1_${ik}$ ) = xr2
x( 1_${ik}$, 2_${ik}$ ) = xi1
x( 2_${ik}$, 2_${ik}$ ) = xi2
end if
xnorm = max( abs( xr1 )+abs( xi1 ), abs( xr2 )+abs( xi2 ) )
! further scaling if norm(a) norm(x) > overflow
if( xnorm>one .and. cmax>one ) then
if( xnorm>bignum / cmax ) then
temp = cmax / bignum
x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ )
xnorm = temp*xnorm
scale = temp*scale
end if
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$laln2
#:endif
#:endfor
module subroutine stdlib${ii}$_strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! STRSYL solves the real Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**T, and A and B are both upper quasi-
!! triangular. A is M-by-M and B is N-by-N; the right hand side C and
!! the solution X are M-by-N; and scale is an output scale factor, set
!! <= 1 to avoid overflow in X.
!! A and B must be in Schur canonical form (as returned by SHSEQR), that
!! is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!! each 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack 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) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(sp), intent(out) :: scale
! Array Arguments
real(sp), intent(in) :: a(lda,*), b(ldb,*)
real(sp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext
real(sp) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, &
xnorm
! Local Arrays
real(sp) :: dum(1_${ik}$), vec(2_${ik}$,2_${ik}$), x(2_${ik}$,2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'T' ) .and. .not.stdlib_lsame( trana, &
'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'T' ) .and. .not.stdlib_lsame( &
tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=sp) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_slange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_slange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
! start column loop (index = l)
! l1 (l2) : column index of the first (first) row of x(k,l).
lnext = 1_${ik}$
loop_70: do l = 1, n
if( l<lnext )cycle loop_70
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l).
knext = m
loop_60: do k = m, 1, -1
if( k>knext )cycle loop_60
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, &
l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_60
end do loop_70
else if( .not.notrna .and. notrnb ) then
! solve a**t *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 l-1
! r(k,l) = sum [a(i,k)**t*x(i,l)] +isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = 1_${ik}$
loop_130: do l = 1, n
if( l<lnext )cycle loop_130
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_120: do k = 1, m
if( k<knext )cycle loop_120
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_120
end do loop_130
else if( .not.notrna .and. .not.notrnb ) then
! solve a**t*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! top-right corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! k-1 n
! r(k,l) = sum [a(i,k)**t*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_190: do l = n, 1, -1
if( l>lnext )cycle loop_190
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_180: do k = 1, m
if( k<knext )cycle loop_180
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min(l2+1, n )&
), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 &
), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_180
end do loop_190
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-right corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=k+1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_250: do l = n, 1, -1
if( l>lnext )cycle loop_250
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = m
loop_240: do k = m, 1, -1
if( k>knext )cycle loop_240
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( m-k1, a( k1, min(k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_slasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_240
end do loop_250
end if
return
end subroutine stdlib${ii}$_strsyl
module subroutine stdlib${ii}$_dtrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! DTRSYL solves the real Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**T, and A and B are both upper quasi-
!! triangular. A is M-by-M and B is N-by-N; the right hand side C and
!! the solution X are M-by-N; and scale is an output scale factor, set
!! <= 1 to avoid overflow in X.
!! A and B must be in Schur canonical form (as returned by DHSEQR), that
!! is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!! each 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack 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) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(dp), intent(out) :: scale
! Array Arguments
real(dp), intent(in) :: a(lda,*), b(ldb,*)
real(dp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext
real(dp) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, &
xnorm
! Local Arrays
real(dp) :: dum(1_${ik}$), vec(2_${ik}$,2_${ik}$), x(2_${ik}$,2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'T' ) .and. .not.stdlib_lsame( trana, &
'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'T' ) .and. .not.stdlib_lsame( &
tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=dp) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_dlange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_dlange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
! start column loop (index = l)
! l1 (l2) : column index of the first (first) row of x(k,l).
lnext = 1_${ik}$
loop_60: do l = 1, n
if( l<lnext )cycle loop_60
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l).
knext = m
loop_50: do k = m, 1, -1
if( k>knext )cycle loop_50
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, &
l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_50
end do loop_60
else if( .not.notrna .and. notrnb ) then
! solve a**t *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 t l-1
! r(k,l) = sum [a(i,k)**t*x(i,l)] +isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = 1_${ik}$
loop_120: do l = 1, n
if( l<lnext )cycle loop_120
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_110: do k = 1, m
if( k<knext )cycle loop_110
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_110
end do loop_120
else if( .not.notrna .and. .not.notrnb ) then
! solve a**t*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! top-right corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! k-1 n
! r(k,l) = sum [a(i,k)**t*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_180: do l = n, 1, -1
if( l>lnext )cycle loop_180
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_170: do k = 1, m
if( k<knext )cycle loop_170
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 &
), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_170
end do loop_180
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-right corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=k+1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_240: do l = n, 1, -1
if( l>lnext )cycle loop_240
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = m
loop_230: do k = m, 1, -1
if( k>knext )cycle loop_230
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_dlasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_230
end do loop_240
end if
return
end subroutine stdlib${ii}$_dtrsyl
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$trsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! DTRSYL: solves the real Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**T, and A and B are both upper quasi-
!! triangular. A is M-by-M and B is N-by-N; the right hand side C and
!! the solution X are M-by-N; and scale is an output scale factor, set
!! <= 1 to avoid overflow in X.
!! A and B must be in Schur canonical form (as returned by DHSEQR), that
!! is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!! each 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(${rk}$), intent(out) :: scale
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext
real(${rk}$) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, &
xnorm
! Local Arrays
real(${rk}$) :: dum(1_${ik}$), vec(2_${ik}$,2_${ik}$), x(2_${ik}$,2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'T' ) .and. .not.stdlib_lsame( trana, &
'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'T' ) .and. .not.stdlib_lsame( &
tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=${rk}$) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_${ri}$lange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_${ri}$lange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
! start column loop (index = l)
! l1 (l2) : column index of the first (first) row of x(k,l).
lnext = 1_${ik}$
loop_60: do l = 1, n
if( l<lnext )cycle loop_60
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l).
knext = m
loop_50: do k = m, 1, -1
if( k>knext )cycle loop_50
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$lasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, &
l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_50
end do loop_60
else if( .not.notrna .and. notrnb ) then
! solve a**t *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 t l-1
! r(k,l) = sum [a(i,k)**t*x(i,l)] +isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = 1_${ik}$
loop_120: do l = 1, n
if( l<lnext )cycle loop_120
if( l==n ) then
l1 = l
l2 = l
else
if( b( l+1, l )/=zero ) then
l1 = l
l2 = l + 1_${ik}$
lnext = l + 2_${ik}$
else
l1 = l
l2 = l
lnext = l + 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_110: do k = 1, m
if( k<knext )cycle loop_110
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$lasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_110
end do loop_120
else if( .not.notrna .and. .not.notrnb ) then
! solve a**t*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! top-right corner column by column by
! a(k,k)**t*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! k-1 n
! r(k,l) = sum [a(i,k)**t*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_180: do l = n, 1, -1
if( l>lnext )cycle loop_180
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = 1_${ik}$
loop_170: do k = 1, m
if( k<knext )cycle loop_170
if( k==m ) then
k1 = k
k2 = k
else
if( a( k+1, k )/=zero ) then
k1 = k
k2 = k + 1_${ik}$
knext = k + 2_${ik}$
else
k1 = k
k2 = k
knext = k + 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$lasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 &
), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_170
end do loop_180
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**t = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-right corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l)**t = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b(l,j)**t].
! i=k+1 j=l+1
! start column loop (index = l)
! l1 (l2): column index of the first (last) row of x(k,l)
lnext = n
loop_240: do l = n, 1, -1
if( l>lnext )cycle loop_240
if( l==1_${ik}$ ) then
l1 = l
l2 = l
else
if( b( l, l-1 )/=zero ) then
l1 = l - 1_${ik}$
l2 = l
lnext = l - 2_${ik}$
else
l1 = l
l2 = l
lnext = l - 1_${ik}$
end if
end if
! start row loop (index = k)
! k1 (k2): row index of the first (last) row of x(k,l)
knext = m
loop_230: do k = m, 1, -1
if( k>knext )cycle loop_230
if( k==1_${ik}$ ) then
k1 = k
k2 = k
else
if( a( k, k-1 )/=zero ) then
k1 = k - 1_${ik}$
k2 = k
knext = k - 2_${ik}$
else
k1 = k
k2 = k
knext = k - 1_${ik}$
end if
end if
if( l1==l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k1, k1 ) + sgn*b( l1, l1 )
da11 = abs( a11 )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( vec( 1_${ik}$, 1_${ik}$ ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
else if( l1==l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, &
vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1==k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) )
suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) )
call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, &
vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ )
else if( l1/=l2 .and. k1/=k2 ) then
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l1 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr )
suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), &
l2 ), 1_${ik}$ )
sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n &
) ), ldb )
vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr )
call stdlib${ii}$_${ri}$lasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, &
l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr )
if( ierr/=0_${ik}$ )info = 1_${ik}$
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ )
c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ )
c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ )
c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ )
end if
end do loop_230
end do loop_240
end if
return
end subroutine stdlib${ii}$_${ri}$trsyl
#:endif
#:endfor
module subroutine stdlib${ii}$_ctrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! CTRSYL solves the complex Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**H, and A and B are both upper triangular. A is
!! M-by-M and B is N-by-N; the right hand side C and the solution X are
!! M-by-N; and scale is an output scale factor, set <= 1 to avoid
!! overflow in X.
! -- lapack computational routine --
! -- lapack 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) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(sp), intent(out) :: scale
! Array Arguments
complex(sp), intent(in) :: a(lda,*), b(ldb,*)
complex(sp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: j, k, l
real(sp) :: bignum, da11, db, eps, scaloc, sgn, smin, smlnum
complex(sp) :: a11, suml, sumr, vec, x11
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=sp) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_clange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_clange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] +isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
loop_30: do l = 1, n
do k = m, 1, -1
suml = stdlib${ii}$_cdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_cdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k, k ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=sp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_30
else if( .not.notrna .and. notrnb ) then
! solve a**h *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 l-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
loop_60: do l = 1, n
do k = 1, m
suml = stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_cdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = conjg( a( k, k ) ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=sp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_60
else if( .not.notrna .and. .not.notrnb ) then
! solve a**h*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! upper-right corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! k-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] +
! i=1
! n
! isgn*sum [x(k,j)*b**h(l,j)].
! j=l+1
loop_90: do l = n, 1, -1
do k = 1, m
suml = stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = conjg( a( k, k )+sgn*b( l, l ) )
da11 = abs( real( a11,KIND=sp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_90
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b**h(l,j)]
! i=k+1 j=l+1
loop_120: do l = n, 1, -1
do k = m, 1, -1
suml = stdlib${ii}$_cdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = a( k, k ) + sgn*conjg( b( l, l ) )
da11 = abs( real( a11,KIND=sp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_120
end if
return
end subroutine stdlib${ii}$_ctrsyl
module subroutine stdlib${ii}$_ztrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! ZTRSYL solves the complex Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**H, and A and B are both upper triangular. A is
!! M-by-M and B is N-by-N; the right hand side C and the solution X are
!! M-by-N; and scale is an output scale factor, set <= 1 to avoid
!! overflow in X.
! -- lapack computational routine --
! -- lapack 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) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(dp), intent(out) :: scale
! Array Arguments
complex(dp), intent(in) :: a(lda,*), b(ldb,*)
complex(dp), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: j, k, l
real(dp) :: bignum, da11, db, eps, scaloc, sgn, smin, smlnum
complex(dp) :: a11, suml, sumr, vec, x11
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=dp) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_zlange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_zlange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] +isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
loop_30: do l = 1, n
do k = m, 1, -1
suml = stdlib${ii}$_zdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_zdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k, k ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=dp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_30
else if( .not.notrna .and. notrnb ) then
! solve a**h *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 l-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
loop_60: do l = 1, n
do k = 1, m
suml = stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_zdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = conjg( a( k, k ) ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=dp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_60
else if( .not.notrna .and. .not.notrnb ) then
! solve a**h*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! upper-right corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! k-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] +
! i=1
! n
! isgn*sum [x(k,j)*b**h(l,j)].
! j=l+1
loop_90: do l = n, 1, -1
do k = 1, m
suml = stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = conjg( a( k, k )+sgn*b( l, l ) )
da11 = abs( real( a11,KIND=dp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_90
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b**h(l,j)]
! i=k+1 j=l+1
loop_120: do l = n, 1, -1
do k = m, 1, -1
suml = stdlib${ii}$_zdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = a( k, k ) + sgn*conjg( b( l, l ) )
da11 = abs( real( a11,KIND=dp) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_120
end if
return
end subroutine stdlib${ii}$_ztrsyl
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$trsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info )
!! ZTRSYL: solves the complex Sylvester matrix equation:
!! op(A)*X + X*op(B) = scale*C or
!! op(A)*X - X*op(B) = scale*C,
!! where op(A) = A or A**H, and A and B are both upper triangular. A is
!! M-by-M and B is N-by-N; the right hand side C and the solution X are
!! M-by-N; and scale is an output scale factor, set <= 1 to avoid
!! overflow in X.
! -- lapack computational routine --
! -- lapack 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) :: trana, tranb
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n
real(${ck}$), intent(out) :: scale
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(inout) :: c(ldc,*)
! =====================================================================
! Local Scalars
logical(lk) :: notrna, notrnb
integer(${ik}$) :: j, k, l
real(${ck}$) :: bignum, da11, db, eps, scaloc, sgn, smin, smlnum
complex(${ck}$) :: a11, suml, sumr, vec, x11
! Local Arrays
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test input parameters
notrna = stdlib_lsame( trana, 'N' )
notrnb = stdlib_lsame( tranb, 'N' )
info = 0_${ik}$
if( .not.notrna .and. .not.stdlib_lsame( trana, 'C' ) ) then
info = -1_${ik}$
else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'C' ) ) then
info = -2_${ik}$
else if( isgn/=1_${ik}$ .and. isgn/=-1_${ik}$ ) then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, m ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -11_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSYL', -info )
return
end if
! quick return if possible
scale = one
if( m==0 .or. n==0 )return
! set constants to control overflow
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = smlnum*real( m*n,KIND=${ck}$) / eps
bignum = one / smlnum
smin = max( smlnum, eps*stdlib${ii}$_${ci}$lange( 'M', m, m, a, lda, dum ),eps*stdlib${ii}$_${ci}$lange( 'M',&
n, n, b, ldb, dum ) )
sgn = isgn
if( notrna .and. notrnb ) then
! solve a*x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! m l-1
! r(k,l) = sum [a(k,i)*x(i,l)] +isgn*sum [x(k,j)*b(j,l)].
! i=k+1 j=1
loop_30: do l = 1, n
do k = m, 1, -1
suml = stdlib${ii}$_${ci}$dotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_${ci}$dotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = a( k, k ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_30
else if( .not.notrna .and. notrnb ) then
! solve a**h *x + isgn*x*b = scale*c.
! the (k,l)th block of x is determined starting from
! upper-left corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b(l,l) = c(k,l) - r(k,l)
! where
! k-1 l-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] + isgn*sum [x(k,j)*b(j,l)]
! i=1 j=1
loop_60: do l = 1, n
do k = 1, m
suml = stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_${ci}$dotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ )
vec = c( k, l ) - ( suml+sgn*sumr )
scaloc = one
a11 = conjg( a( k, k ) ) + sgn*b( l, l )
da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_60
else if( .not.notrna .and. .not.notrnb ) then
! solve a**h*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! upper-right corner column by column by
! a**h(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! k-1
! r(k,l) = sum [a**h(i,k)*x(i,l)] +
! i=1
! n
! isgn*sum [x(k,j)*b**h(l,j)].
! j=l+1
loop_90: do l = n, 1, -1
do k = 1, m
suml = stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ )
sumr = stdlib${ii}$_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = conjg( a( k, k )+sgn*b( l, l ) )
da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_90
else if( notrna .and. .not.notrnb ) then
! solve a*x + isgn*x*b**h = c.
! the (k,l)th block of x is determined starting from
! bottom-left corner column by column by
! a(k,k)*x(k,l) + isgn*x(k,l)*b**h(l,l) = c(k,l) - r(k,l)
! where
! m n
! r(k,l) = sum [a(k,i)*x(i,l)] + isgn*sum [x(k,j)*b**h(l,j)]
! i=k+1 j=l+1
loop_120: do l = n, 1, -1
do k = m, 1, -1
suml = stdlib${ii}$_${ci}$dotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ &
)
sumr = stdlib${ii}$_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), &
ldb )
vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
scaloc = one
a11 = a( k, k ) + sgn*conjg( b( l, l ) )
da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) )
if( da11<=smin ) then
a11 = smin
da11 = smin
info = 1_${ik}$
end if
db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) )
if( da11<one .and. db>one ) then
if( db>bignum*da11 )scaloc = one / db
end if
x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 )
if( scaloc/=one ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ )
end do
scale = scale*scaloc
end if
c( k, l ) = x11
end do
end do loop_120
end if
return
end subroutine stdlib${ii}$_${ci}$trsyl
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, &
!! SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
!! op(TL)*X + ISGN*X*op(TR) = SCALE*B,
!! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
!! -1. op(T) = T or T**T, where T**T denotes the transpose of T.
scale, x, ldx, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltranl, ltranr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2
real(sp), intent(out) :: scale, xnorm
! Array Arguments
real(sp), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*)
real(sp), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: bswap, xswap
integer(${ik}$) :: i, ip, ipiv, ipsv, j, jp, jpsv, k
real(sp) :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, &
xmax
! Local Arrays
logical(lk) :: bswpiv(4_${ik}$), xswpiv(4_${ik}$)
integer(${ik}$) :: jpiv(4_${ik}$), locl21(4_${ik}$), locu12(4_${ik}$), locu22(4_${ik}$)
real(sp) :: btmp(4_${ik}$), t16(4_${ik}$,4_${ik}$), tmp(4_${ik}$), x2(2_${ik}$)
! Intrinsic Functions
! Data Statements
locu12 = [3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$]
locl21 = [2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$]
locu22 = [4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$]
xswpiv = [.false.,.false.,.true.,.true.]
bswpiv = [.false.,.true.,.false.,.true.]
! Executable Statements
! do not check the input parameters for errors
info = 0_${ik}$
! quick return if possible
if( n1==0 .or. n2==0 )return
! set constants to control overflow
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
sgn = isgn
k = n1 + n1 + n2 - 2_${ik}$
go to ( 10, 20, 30, 50 )k
! 1 by 1: tl11*x + sgn*x*tr11 = b11
10 continue
tau1 = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
bet = abs( tau1 )
if( bet<=smlnum ) then
tau1 = smlnum
bet = smlnum
info = 1_${ik}$
end if
scale = one
gam = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( smlnum*gam>bet )scale = one / gam
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / tau1
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
return
! 1 by 2:
! tl11*[x11 x12] + isgn*[x11 x12]*op[tr11 tr12] = [b11 b12]
! [tr21 tr22]
20 continue
smin = max( eps*max( abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 1_${ik}$ ) ),abs( tr( 1_${ik}$, 2_${ik}$ ) ), abs( tr( &
2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranr ) then
tmp( 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
else
tmp( 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
go to 40
! 2 by 1:
! op[tl11 tl12]*[x11] + isgn* [x11]*tr11 = [b11]
! [tl21 tl22] [x21] [x21] [b21]
30 continue
smin = max( eps*max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 1_${ik}$ ) ),abs( tl( 1_${ik}$, 2_${ik}$ ) ), abs( tl( &
2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
if( ltranl ) then
tmp( 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
else
tmp( 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
40 continue
! solve 2 by 2 system using complete pivoting.
! set pivots less than smin to smin.
ipiv = stdlib${ii}$_isamax( 4_${ik}$, tmp, 1_${ik}$ )
u11 = tmp( ipiv )
if( abs( u11 )<=smin ) then
info = 1_${ik}$
u11 = smin
end if
u12 = tmp( locu12( ipiv ) )
l21 = tmp( locl21( ipiv ) ) / u11
u22 = tmp( locu22( ipiv ) ) - u12*l21
xswap = xswpiv( ipiv )
bswap = bswpiv( ipiv )
if( abs( u22 )<=smin ) then
info = 1_${ik}$
u22 = smin
end if
if( bswap ) then
temp = btmp( 2_${ik}$ )
btmp( 2_${ik}$ ) = btmp( 1_${ik}$ ) - l21*temp
btmp( 1_${ik}$ ) = temp
else
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ ) - l21*btmp( 1_${ik}$ )
end if
scale = one
if( ( two*smlnum )*abs( btmp( 2_${ik}$ ) )>abs( u22 ) .or.( two*smlnum )*abs( btmp( 1_${ik}$ ) )>abs(&
u11 ) ) then
scale = half / max( abs( btmp( 1_${ik}$ ) ), abs( btmp( 2_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
end if
x2( 2_${ik}$ ) = btmp( 2_${ik}$ ) / u22
x2( 1_${ik}$ ) = btmp( 1_${ik}$ ) / u11 - ( u12 / u11 )*x2( 2_${ik}$ )
if( xswap ) then
temp = x2( 2_${ik}$ )
x2( 2_${ik}$ ) = x2( 1_${ik}$ )
x2( 1_${ik}$ ) = temp
end if
x( 1_${ik}$, 1_${ik}$ ) = x2( 1_${ik}$ )
if( n1==1_${ik}$ ) then
x( 1_${ik}$, 2_${ik}$ ) = x2( 2_${ik}$ )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
else
x( 2_${ik}$, 1_${ik}$ ) = x2( 2_${ik}$ )
xnorm = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 2_${ik}$, 1_${ik}$ ) ) )
end if
return
! 2 by 2:
! op[tl11 tl12]*[x11 x12] +isgn* [x11 x12]*op[tr11 tr12] = [b11 b12]
! [tl21 tl22] [x21 x22] [x21 x22] [tr21 tr22] [b21 b22]
! solve equivalent 4 by 4 system using complete pivoting.
! set pivots less than smin to smin.
50 continue
smin = max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 2_${ik}$ ) ),abs( tr( 2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) )
smin = max( smin, abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 2_${ik}$ ) ),abs( tl( 2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, &
2_${ik}$ ) ) )
smin = max( eps*smin, smlnum )
btmp( 1_${ik}$ ) = zero
call stdlib${ii}$_scopy( 16_${ik}$, btmp, 0_${ik}$, t16, 1_${ik}$ )
t16( 1_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranl ) then
t16( 1_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
else
t16( 1_${ik}$, 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
end if
if( ltranr ) then
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
else
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
btmp( 3_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
btmp( 4_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ )
! perform elimination
loop_100: do i = 1, 3
xmax = zero
do ip = i, 4
do jp = i, 4
if( abs( t16( ip, jp ) )>=xmax ) then
xmax = abs( t16( ip, jp ) )
ipsv = ip
jpsv = jp
end if
end do
end do
if( ipsv/=i ) then
call stdlib${ii}$_sswap( 4_${ik}$, t16( ipsv, 1_${ik}$ ), 4_${ik}$, t16( i, 1_${ik}$ ), 4_${ik}$ )
temp = btmp( i )
btmp( i ) = btmp( ipsv )
btmp( ipsv ) = temp
end if
if( jpsv/=i )call stdlib${ii}$_sswap( 4_${ik}$, t16( 1_${ik}$, jpsv ), 1_${ik}$, t16( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpsv
if( abs( t16( i, i ) )<smin ) then
info = 1_${ik}$
t16( i, i ) = smin
end if
do j = i + 1, 4
t16( j, i ) = t16( j, i ) / t16( i, i )
btmp( j ) = btmp( j ) - t16( j, i )*btmp( i )
do k = i + 1, 4
t16( j, k ) = t16( j, k ) - t16( j, i )*t16( i, k )
end do
end do
end do loop_100
if( abs( t16( 4_${ik}$, 4_${ik}$ ) )<smin ) then
info = 1_${ik}$
t16( 4_${ik}$, 4_${ik}$ ) = smin
end if
scale = one
if( ( eight*smlnum )*abs( btmp( 1_${ik}$ ) )>abs( t16( 1_${ik}$, 1_${ik}$ ) ) .or.( eight*smlnum )*abs( &
btmp( 2_${ik}$ ) )>abs( t16( 2_${ik}$, 2_${ik}$ ) ) .or.( eight*smlnum )*abs( btmp( 3_${ik}$ ) )>abs( t16( 3_${ik}$, 3_${ik}$ ) )&
.or.( eight*smlnum )*abs( btmp( 4_${ik}$ ) )>abs( t16( 4_${ik}$, 4_${ik}$ ) ) ) then
scale = ( one / eight ) / max( abs( btmp( 1_${ik}$ ) ),abs( btmp( 2_${ik}$ ) ), abs( btmp( 3_${ik}$ ) ), &
abs( btmp( 4_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
btmp( 3_${ik}$ ) = btmp( 3_${ik}$ )*scale
btmp( 4_${ik}$ ) = btmp( 4_${ik}$ )*scale
end if
do i = 1, 4
k = 5_${ik}$ - i
temp = one / t16( k, k )
tmp( k ) = btmp( k )*temp
do j = k + 1, 4
tmp( k ) = tmp( k ) - ( temp*t16( k, j ) )*tmp( j )
end do
end do
do i = 1, 3
if( jpiv( 4_${ik}$-i )/=4_${ik}$-i ) then
temp = tmp( 4_${ik}$-i )
tmp( 4_${ik}$-i ) = tmp( jpiv( 4_${ik}$-i ) )
tmp( jpiv( 4_${ik}$-i ) ) = temp
end if
end do
x( 1_${ik}$, 1_${ik}$ ) = tmp( 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = tmp( 2_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = tmp( 3_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = tmp( 4_${ik}$ )
xnorm = max( abs( tmp( 1_${ik}$ ) )+abs( tmp( 3_${ik}$ ) ),abs( tmp( 2_${ik}$ ) )+abs( tmp( 4_${ik}$ ) ) )
return
end subroutine stdlib${ii}$_slasy2
pure module subroutine stdlib${ii}$_dlasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, &
!! DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
!! op(TL)*X + ISGN*X*op(TR) = SCALE*B,
!! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
!! -1. op(T) = T or T**T, where T**T denotes the transpose of T.
scale, x, ldx, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltranl, ltranr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2
real(dp), intent(out) :: scale, xnorm
! Array Arguments
real(dp), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*)
real(dp), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: bswap, xswap
integer(${ik}$) :: i, ip, ipiv, ipsv, j, jp, jpsv, k
real(dp) :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, &
xmax
! Local Arrays
logical(lk) :: bswpiv(4_${ik}$), xswpiv(4_${ik}$)
integer(${ik}$) :: jpiv(4_${ik}$), locl21(4_${ik}$), locu12(4_${ik}$), locu22(4_${ik}$)
real(dp) :: btmp(4_${ik}$), t16(4_${ik}$,4_${ik}$), tmp(4_${ik}$), x2(2_${ik}$)
! Intrinsic Functions
! Data Statements
locu12 = [3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$]
locl21 = [2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$]
locu22 = [4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$]
xswpiv = [.false.,.false.,.true.,.true.]
bswpiv = [.false.,.true.,.false.,.true.]
! Executable Statements
! do not check the input parameters for errors
info = 0_${ik}$
! quick return if possible
if( n1==0 .or. n2==0 )return
! set constants to control overflow
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
sgn = isgn
k = n1 + n1 + n2 - 2_${ik}$
go to ( 10, 20, 30, 50 )k
! 1 by 1: tl11*x + sgn*x*tr11 = b11
10 continue
tau1 = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
bet = abs( tau1 )
if( bet<=smlnum ) then
tau1 = smlnum
bet = smlnum
info = 1_${ik}$
end if
scale = one
gam = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( smlnum*gam>bet )scale = one / gam
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / tau1
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
return
! 1 by 2:
! tl11*[x11 x12] + isgn*[x11 x12]*op[tr11 tr12] = [b11 b12]
! [tr21 tr22]
20 continue
smin = max( eps*max( abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 1_${ik}$ ) ),abs( tr( 1_${ik}$, 2_${ik}$ ) ), abs( tr( &
2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranr ) then
tmp( 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
else
tmp( 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
go to 40
! 2 by 1:
! op[tl11 tl12]*[x11] + isgn* [x11]*tr11 = [b11]
! [tl21 tl22] [x21] [x21] [b21]
30 continue
smin = max( eps*max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 1_${ik}$ ) ),abs( tl( 1_${ik}$, 2_${ik}$ ) ), abs( tl( &
2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
if( ltranl ) then
tmp( 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
else
tmp( 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
40 continue
! solve 2 by 2 system using complete pivoting.
! set pivots less than smin to smin.
ipiv = stdlib${ii}$_idamax( 4_${ik}$, tmp, 1_${ik}$ )
u11 = tmp( ipiv )
if( abs( u11 )<=smin ) then
info = 1_${ik}$
u11 = smin
end if
u12 = tmp( locu12( ipiv ) )
l21 = tmp( locl21( ipiv ) ) / u11
u22 = tmp( locu22( ipiv ) ) - u12*l21
xswap = xswpiv( ipiv )
bswap = bswpiv( ipiv )
if( abs( u22 )<=smin ) then
info = 1_${ik}$
u22 = smin
end if
if( bswap ) then
temp = btmp( 2_${ik}$ )
btmp( 2_${ik}$ ) = btmp( 1_${ik}$ ) - l21*temp
btmp( 1_${ik}$ ) = temp
else
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ ) - l21*btmp( 1_${ik}$ )
end if
scale = one
if( ( two*smlnum )*abs( btmp( 2_${ik}$ ) )>abs( u22 ) .or.( two*smlnum )*abs( btmp( 1_${ik}$ ) )>abs(&
u11 ) ) then
scale = half / max( abs( btmp( 1_${ik}$ ) ), abs( btmp( 2_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
end if
x2( 2_${ik}$ ) = btmp( 2_${ik}$ ) / u22
x2( 1_${ik}$ ) = btmp( 1_${ik}$ ) / u11 - ( u12 / u11 )*x2( 2_${ik}$ )
if( xswap ) then
temp = x2( 2_${ik}$ )
x2( 2_${ik}$ ) = x2( 1_${ik}$ )
x2( 1_${ik}$ ) = temp
end if
x( 1_${ik}$, 1_${ik}$ ) = x2( 1_${ik}$ )
if( n1==1_${ik}$ ) then
x( 1_${ik}$, 2_${ik}$ ) = x2( 2_${ik}$ )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
else
x( 2_${ik}$, 1_${ik}$ ) = x2( 2_${ik}$ )
xnorm = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 2_${ik}$, 1_${ik}$ ) ) )
end if
return
! 2 by 2:
! op[tl11 tl12]*[x11 x12] +isgn* [x11 x12]*op[tr11 tr12] = [b11 b12]
! [tl21 tl22] [x21 x22] [x21 x22] [tr21 tr22] [b21 b22]
! solve equivalent 4 by 4 system using complete pivoting.
! set pivots less than smin to smin.
50 continue
smin = max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 2_${ik}$ ) ),abs( tr( 2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) )
smin = max( smin, abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 2_${ik}$ ) ),abs( tl( 2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, &
2_${ik}$ ) ) )
smin = max( eps*smin, smlnum )
btmp( 1_${ik}$ ) = zero
call stdlib${ii}$_dcopy( 16_${ik}$, btmp, 0_${ik}$, t16, 1_${ik}$ )
t16( 1_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranl ) then
t16( 1_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
else
t16( 1_${ik}$, 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
end if
if( ltranr ) then
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
else
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
btmp( 3_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
btmp( 4_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ )
! perform elimination
loop_100: do i = 1, 3
xmax = zero
do ip = i, 4
do jp = i, 4
if( abs( t16( ip, jp ) )>=xmax ) then
xmax = abs( t16( ip, jp ) )
ipsv = ip
jpsv = jp
end if
end do
end do
if( ipsv/=i ) then
call stdlib${ii}$_dswap( 4_${ik}$, t16( ipsv, 1_${ik}$ ), 4_${ik}$, t16( i, 1_${ik}$ ), 4_${ik}$ )
temp = btmp( i )
btmp( i ) = btmp( ipsv )
btmp( ipsv ) = temp
end if
if( jpsv/=i )call stdlib${ii}$_dswap( 4_${ik}$, t16( 1_${ik}$, jpsv ), 1_${ik}$, t16( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpsv
if( abs( t16( i, i ) )<smin ) then
info = 1_${ik}$
t16( i, i ) = smin
end if
do j = i + 1, 4
t16( j, i ) = t16( j, i ) / t16( i, i )
btmp( j ) = btmp( j ) - t16( j, i )*btmp( i )
do k = i + 1, 4
t16( j, k ) = t16( j, k ) - t16( j, i )*t16( i, k )
end do
end do
end do loop_100
if( abs( t16( 4_${ik}$, 4_${ik}$ ) )<smin ) then
info = 1_${ik}$
t16( 4_${ik}$, 4_${ik}$ ) = smin
end if
scale = one
if( ( eight*smlnum )*abs( btmp( 1_${ik}$ ) )>abs( t16( 1_${ik}$, 1_${ik}$ ) ) .or.( eight*smlnum )*abs( &
btmp( 2_${ik}$ ) )>abs( t16( 2_${ik}$, 2_${ik}$ ) ) .or.( eight*smlnum )*abs( btmp( 3_${ik}$ ) )>abs( t16( 3_${ik}$, 3_${ik}$ ) )&
.or.( eight*smlnum )*abs( btmp( 4_${ik}$ ) )>abs( t16( 4_${ik}$, 4_${ik}$ ) ) ) then
scale = ( one / eight ) / max( abs( btmp( 1_${ik}$ ) ),abs( btmp( 2_${ik}$ ) ), abs( btmp( 3_${ik}$ ) ), &
abs( btmp( 4_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
btmp( 3_${ik}$ ) = btmp( 3_${ik}$ )*scale
btmp( 4_${ik}$ ) = btmp( 4_${ik}$ )*scale
end if
do i = 1, 4
k = 5_${ik}$ - i
temp = one / t16( k, k )
tmp( k ) = btmp( k )*temp
do j = k + 1, 4
tmp( k ) = tmp( k ) - ( temp*t16( k, j ) )*tmp( j )
end do
end do
do i = 1, 3
if( jpiv( 4_${ik}$-i )/=4_${ik}$-i ) then
temp = tmp( 4_${ik}$-i )
tmp( 4_${ik}$-i ) = tmp( jpiv( 4_${ik}$-i ) )
tmp( jpiv( 4_${ik}$-i ) ) = temp
end if
end do
x( 1_${ik}$, 1_${ik}$ ) = tmp( 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = tmp( 2_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = tmp( 3_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = tmp( 4_${ik}$ )
xnorm = max( abs( tmp( 1_${ik}$ ) )+abs( tmp( 3_${ik}$ ) ),abs( tmp( 2_${ik}$ ) )+abs( tmp( 4_${ik}$ ) ) )
return
end subroutine stdlib${ii}$_dlasy2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, &
!! DLASY2: solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
!! op(TL)*X + ISGN*X*op(TR) = SCALE*B,
!! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
!! -1. op(T) = T or T**T, where T**T denotes the transpose of T.
scale, x, ldx, xnorm, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: ltranl, ltranr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2
real(${rk}$), intent(out) :: scale, xnorm
! Array Arguments
real(${rk}$), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*)
real(${rk}$), intent(out) :: x(ldx,*)
! =====================================================================
! Local Scalars
logical(lk) :: bswap, xswap
integer(${ik}$) :: i, ip, ipiv, ipsv, j, jp, jpsv, k
real(${rk}$) :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, &
xmax
! Local Arrays
logical(lk) :: bswpiv(4_${ik}$), xswpiv(4_${ik}$)
integer(${ik}$) :: jpiv(4_${ik}$), locl21(4_${ik}$), locu12(4_${ik}$), locu22(4_${ik}$)
real(${rk}$) :: btmp(4_${ik}$), t16(4_${ik}$,4_${ik}$), tmp(4_${ik}$), x2(2_${ik}$)
! Intrinsic Functions
! Data Statements
locu12 = [3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$]
locl21 = [2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$]
locu22 = [4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$]
xswpiv = [.false.,.false.,.true.,.true.]
bswpiv = [.false.,.true.,.false.,.true.]
! Executable Statements
! do not check the input parameters for errors
info = 0_${ik}$
! quick return if possible
if( n1==0 .or. n2==0 )return
! set constants to control overflow
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps
sgn = isgn
k = n1 + n1 + n2 - 2_${ik}$
go to ( 10, 20, 30, 50 )k
! 1 by 1: tl11*x + sgn*x*tr11 = b11
10 continue
tau1 = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
bet = abs( tau1 )
if( bet<=smlnum ) then
tau1 = smlnum
bet = smlnum
info = 1_${ik}$
end if
scale = one
gam = abs( b( 1_${ik}$, 1_${ik}$ ) )
if( smlnum*gam>bet )scale = one / gam
x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / tau1
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) )
return
! 1 by 2:
! tl11*[x11 x12] + isgn*[x11 x12]*op[tr11 tr12] = [b11 b12]
! [tr21 tr22]
20 continue
smin = max( eps*max( abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 1_${ik}$ ) ),abs( tr( 1_${ik}$, 2_${ik}$ ) ), abs( tr( &
2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranr ) then
tmp( 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
else
tmp( 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
go to 40
! 2 by 1:
! op[tl11 tl12]*[x11] + isgn* [x11]*tr11 = [b11]
! [tl21 tl22] [x21] [x21] [b21]
30 continue
smin = max( eps*max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 1_${ik}$ ) ),abs( tl( 1_${ik}$, 2_${ik}$ ) ), abs( tl( &
2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, 2_${ik}$ ) ) ),smlnum )
tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
tmp( 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
if( ltranl ) then
tmp( 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
tmp( 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
else
tmp( 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
tmp( 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
40 continue
! solve 2 by 2 system using complete pivoting.
! set pivots less than smin to smin.
ipiv = stdlib${ii}$_i${ri}$amax( 4_${ik}$, tmp, 1_${ik}$ )
u11 = tmp( ipiv )
if( abs( u11 )<=smin ) then
info = 1_${ik}$
u11 = smin
end if
u12 = tmp( locu12( ipiv ) )
l21 = tmp( locl21( ipiv ) ) / u11
u22 = tmp( locu22( ipiv ) ) - u12*l21
xswap = xswpiv( ipiv )
bswap = bswpiv( ipiv )
if( abs( u22 )<=smin ) then
info = 1_${ik}$
u22 = smin
end if
if( bswap ) then
temp = btmp( 2_${ik}$ )
btmp( 2_${ik}$ ) = btmp( 1_${ik}$ ) - l21*temp
btmp( 1_${ik}$ ) = temp
else
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ ) - l21*btmp( 1_${ik}$ )
end if
scale = one
if( ( two*smlnum )*abs( btmp( 2_${ik}$ ) )>abs( u22 ) .or.( two*smlnum )*abs( btmp( 1_${ik}$ ) )>abs(&
u11 ) ) then
scale = half / max( abs( btmp( 1_${ik}$ ) ), abs( btmp( 2_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
end if
x2( 2_${ik}$ ) = btmp( 2_${ik}$ ) / u22
x2( 1_${ik}$ ) = btmp( 1_${ik}$ ) / u11 - ( u12 / u11 )*x2( 2_${ik}$ )
if( xswap ) then
temp = x2( 2_${ik}$ )
x2( 2_${ik}$ ) = x2( 1_${ik}$ )
x2( 1_${ik}$ ) = temp
end if
x( 1_${ik}$, 1_${ik}$ ) = x2( 1_${ik}$ )
if( n1==1_${ik}$ ) then
x( 1_${ik}$, 2_${ik}$ ) = x2( 2_${ik}$ )
xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) )
else
x( 2_${ik}$, 1_${ik}$ ) = x2( 2_${ik}$ )
xnorm = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 2_${ik}$, 1_${ik}$ ) ) )
end if
return
! 2 by 2:
! op[tl11 tl12]*[x11 x12] +isgn* [x11 x12]*op[tr11 tr12] = [b11 b12]
! [tl21 tl22] [x21 x22] [x21 x22] [tr21 tr22] [b21 b22]
! solve equivalent 4 by 4 system using complete pivoting.
! set pivots less than smin to smin.
50 continue
smin = max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 2_${ik}$ ) ),abs( tr( 2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) )
smin = max( smin, abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 2_${ik}$ ) ),abs( tl( 2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, &
2_${ik}$ ) ) )
smin = max( eps*smin, smlnum )
btmp( 1_${ik}$ ) = zero
call stdlib${ii}$_${ri}$copy( 16_${ik}$, btmp, 0_${ik}$, t16, 1_${ik}$ )
t16( 1_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ )
if( ltranl ) then
t16( 1_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
else
t16( 1_${ik}$, 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 1_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 4_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ )
end if
if( ltranr ) then
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
else
t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ )
t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ )
end if
btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ )
btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ )
btmp( 3_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ )
btmp( 4_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ )
! perform elimination
loop_100: do i = 1, 3
xmax = zero
do ip = i, 4
do jp = i, 4
if( abs( t16( ip, jp ) )>=xmax ) then
xmax = abs( t16( ip, jp ) )
ipsv = ip
jpsv = jp
end if
end do
end do
if( ipsv/=i ) then
call stdlib${ii}$_${ri}$swap( 4_${ik}$, t16( ipsv, 1_${ik}$ ), 4_${ik}$, t16( i, 1_${ik}$ ), 4_${ik}$ )
temp = btmp( i )
btmp( i ) = btmp( ipsv )
btmp( ipsv ) = temp
end if
if( jpsv/=i )call stdlib${ii}$_${ri}$swap( 4_${ik}$, t16( 1_${ik}$, jpsv ), 1_${ik}$, t16( 1_${ik}$, i ), 1_${ik}$ )
jpiv( i ) = jpsv
if( abs( t16( i, i ) )<smin ) then
info = 1_${ik}$
t16( i, i ) = smin
end if
do j = i + 1, 4
t16( j, i ) = t16( j, i ) / t16( i, i )
btmp( j ) = btmp( j ) - t16( j, i )*btmp( i )
do k = i + 1, 4
t16( j, k ) = t16( j, k ) - t16( j, i )*t16( i, k )
end do
end do
end do loop_100
if( abs( t16( 4_${ik}$, 4_${ik}$ ) )<smin ) then
info = 1_${ik}$
t16( 4_${ik}$, 4_${ik}$ ) = smin
end if
scale = one
if( ( eight*smlnum )*abs( btmp( 1_${ik}$ ) )>abs( t16( 1_${ik}$, 1_${ik}$ ) ) .or.( eight*smlnum )*abs( &
btmp( 2_${ik}$ ) )>abs( t16( 2_${ik}$, 2_${ik}$ ) ) .or.( eight*smlnum )*abs( btmp( 3_${ik}$ ) )>abs( t16( 3_${ik}$, 3_${ik}$ ) )&
.or.( eight*smlnum )*abs( btmp( 4_${ik}$ ) )>abs( t16( 4_${ik}$, 4_${ik}$ ) ) ) then
scale = ( one / eight ) / max( abs( btmp( 1_${ik}$ ) ),abs( btmp( 2_${ik}$ ) ), abs( btmp( 3_${ik}$ ) ), &
abs( btmp( 4_${ik}$ ) ) )
btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale
btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale
btmp( 3_${ik}$ ) = btmp( 3_${ik}$ )*scale
btmp( 4_${ik}$ ) = btmp( 4_${ik}$ )*scale
end if
do i = 1, 4
k = 5_${ik}$ - i
temp = one / t16( k, k )
tmp( k ) = btmp( k )*temp
do j = k + 1, 4
tmp( k ) = tmp( k ) - ( temp*t16( k, j ) )*tmp( j )
end do
end do
do i = 1, 3
if( jpiv( 4_${ik}$-i )/=4_${ik}$-i ) then
temp = tmp( 4_${ik}$-i )
tmp( 4_${ik}$-i ) = tmp( jpiv( 4_${ik}$-i ) )
tmp( jpiv( 4_${ik}$-i ) ) = temp
end if
end do
x( 1_${ik}$, 1_${ik}$ ) = tmp( 1_${ik}$ )
x( 2_${ik}$, 1_${ik}$ ) = tmp( 2_${ik}$ )
x( 1_${ik}$, 2_${ik}$ ) = tmp( 3_${ik}$ )
x( 2_${ik}$, 2_${ik}$ ) = tmp( 4_${ik}$ )
xnorm = max( abs( tmp( 1_${ik}$ ) )+abs( tmp( 3_${ik}$ ) ),abs( tmp( 2_${ik}$ ) )+abs( tmp( 4_${ik}$ ) ) )
return
end subroutine stdlib${ii}$_${ri}$lasy2
#:endif
#:endfor
module subroutine stdlib${ii}$_strsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, m, &
!! STRSNA estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a real upper
!! quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
!! orthogonal).
!! T must be in Schur canonical form (as returned by SHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
work, ldwork, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: s(*), sep(*), work(ldwork,*)
real(sp), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
! =====================================================================
! Local Scalars
logical(lk) :: pair, somcon, wantbh, wants, wantsp
integer(${ik}$) :: i, ierr, ifst, ilst, j, k, kase, ks, n2, nn
real(sp) :: bignum, cond, cs, delta, dumm, eps, est, lnrm, mu, prod, prod1, prod2, &
rnrm, scale, smlnum, sn
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(sp) :: dummy(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of eigenpairs for which condition numbers
! are required, and test mm.
if( somcon ) then
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
ks = 0_${ik}$
pair = .false.
loop_60: do k = 1, n
! determine whether t(k,k) begins a 1-by-1 or 2-by-2 block.
if( pair ) then
pair = .false.
cycle loop_60
else
if( k<n )pair = t( k+1, k )/=zero
end if
! determine whether condition numbers are required for the k-th
! eigenpair.
if( somcon ) then
if( pair ) then
if( .not.select( k ) .and. .not.select( k+1 ) )cycle loop_60
else
if( .not.select( k ) )cycle loop_60
end if
end if
ks = ks + 1_${ik}$
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
if( .not.pair ) then
! real eigenvalue.
prod = stdlib${ii}$_sdot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_snrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_snrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
else
! complex eigenvalue.
prod1 = stdlib${ii}$_sdot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
prod1 = prod1 + stdlib${ii}$_sdot( n, vr( 1_${ik}$, ks+1 ), 1_${ik}$, vl( 1_${ik}$, ks+1 ),1_${ik}$ )
prod2 = stdlib${ii}$_sdot( n, vl( 1_${ik}$, ks ), 1_${ik}$, vr( 1_${ik}$, ks+1 ), 1_${ik}$ )
prod2 = prod2 - stdlib${ii}$_sdot( n, vl( 1_${ik}$, ks+1 ), 1_${ik}$, vr( 1_${ik}$, ks ),1_${ik}$ )
rnrm = stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, vr( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
lnrm = stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, vl( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
cond = stdlib${ii}$_slapy2( prod1, prod2 ) / ( rnrm*lnrm )
s( ks ) = cond
s( ks+1 ) = cond
end if
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the diagonal
! block beginning at t(k,k) to the (1,1) position.
call stdlib${ii}$_slacpy( 'FULL', n, n, t, ldt, work, ldwork )
ifst = k
ilst = 1_${ik}$
call stdlib${ii}$_strexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, ifst, ilst,work( 1_${ik}$, n+1 ),&
ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! could not swap because blocks not well separated
scale = one
est = bignum
else
! reordering successful
if( work( 2_${ik}$, 1_${ik}$ )==zero ) then
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
n2 = 1_${ik}$
nn = n - 1_${ik}$
else
! triangularize the 2 by 2 block by unitary
! transformation u = [ cs i*ss ]
! [ i*ss cs ].
! such that the (1,1) position of work is complex
! eigenvalue lambda with positive imaginary part. (2,2)
! position of work is the complex eigenvalue lambda
! with negative imaginary part.
mu = sqrt( abs( work( 1_${ik}$, 2_${ik}$ ) ) )*sqrt( abs( work( 2_${ik}$, 1_${ik}$ ) ) )
delta = stdlib${ii}$_slapy2( mu, work( 2_${ik}$, 1_${ik}$ ) )
cs = mu / delta
sn = -work( 2_${ik}$, 1_${ik}$ ) / delta
! form
! c**t = work(2:n,2:n) + i*[rwork(1) ..... rwork(n-1) ]
! [ mu ]
! [ .. ]
! [ .. ]
! [ mu ]
! where c**t is transpose of matrix c,
! and rwork is stored starting in the n+1-st column of
! work.
do j = 3, n
work( 2_${ik}$, j ) = cs*work( 2_${ik}$, j )
work( j, j ) = work( j, j ) - work( 1_${ik}$, 1_${ik}$ )
end do
work( 2_${ik}$, 2_${ik}$ ) = zero
work( 1_${ik}$, n+1 ) = two*mu
do i = 2, n - 1
work( i, n+1 ) = sn*work( 1_${ik}$, i+1 )
end do
n2 = 2_${ik}$
nn = 2_${ik}$*( n-1 )
end if
! estimate norm(inv(c**t))
est = zero
kase = 0_${ik}$
50 continue
call stdlib${ii}$_slacn2( nn, work( 1_${ik}$, n+2 ), work( 1_${ik}$, n+4 ), iwork,est, kase, &
isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c**t*x = scale*c.
call stdlib${ii}$_slaqtr( .true., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy, &
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c**t*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_slaqtr( .true., .false., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
else
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c*x = scale*c.
call stdlib${ii}$_slaqtr( .false., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy,&
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_slaqtr( .false., .false., n-1,work( 2_${ik}$, 2_${ik}$ ), ldwork,work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
end if
go to 50
end if
end if
sep( ks ) = scale / max( est, smlnum )
if( pair )sep( ks+1 ) = sep( ks )
end if
if( pair )ks = ks + 1_${ik}$
end do loop_60
return
end subroutine stdlib${ii}$_strsna
module subroutine stdlib${ii}$_dtrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, m, &
!! DTRSNA estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a real upper
!! quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
!! orthogonal).
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
work, ldwork, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: s(*), sep(*), work(ldwork,*)
real(dp), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
! =====================================================================
! Local Scalars
logical(lk) :: pair, somcon, wantbh, wants, wantsp
integer(${ik}$) :: i, ierr, ifst, ilst, j, k, kase, ks, n2, nn
real(dp) :: bignum, cond, cs, delta, dumm, eps, est, lnrm, mu, prod, prod1, prod2, &
rnrm, scale, smlnum, sn
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(dp) :: dummy(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of eigenpairs for which condition numbers
! are required, and test mm.
if( somcon ) then
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
ks = 0_${ik}$
pair = .false.
loop_60: do k = 1, n
! determine whether t(k,k) begins a 1-by-1 or 2-by-2 block.
if( pair ) then
pair = .false.
cycle loop_60
else
if( k<n )pair = t( k+1, k )/=zero
end if
! determine whether condition numbers are required for the k-th
! eigenpair.
if( somcon ) then
if( pair ) then
if( .not.select( k ) .and. .not.select( k+1 ) )cycle loop_60
else
if( .not.select( k ) )cycle loop_60
end if
end if
ks = ks + 1_${ik}$
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
if( .not.pair ) then
! real eigenvalue.
prod = stdlib${ii}$_ddot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
else
! complex eigenvalue.
prod1 = stdlib${ii}$_ddot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
prod1 = prod1 + stdlib${ii}$_ddot( n, vr( 1_${ik}$, ks+1 ), 1_${ik}$, vl( 1_${ik}$, ks+1 ),1_${ik}$ )
prod2 = stdlib${ii}$_ddot( n, vl( 1_${ik}$, ks ), 1_${ik}$, vr( 1_${ik}$, ks+1 ), 1_${ik}$ )
prod2 = prod2 - stdlib${ii}$_ddot( n, vl( 1_${ik}$, ks+1 ), 1_${ik}$, vr( 1_${ik}$, ks ),1_${ik}$ )
rnrm = stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, vr( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
lnrm = stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, vl( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
cond = stdlib${ii}$_dlapy2( prod1, prod2 ) / ( rnrm*lnrm )
s( ks ) = cond
s( ks+1 ) = cond
end if
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the diagonal
! block beginning at t(k,k) to the (1,1) position.
call stdlib${ii}$_dlacpy( 'FULL', n, n, t, ldt, work, ldwork )
ifst = k
ilst = 1_${ik}$
call stdlib${ii}$_dtrexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, ifst, ilst,work( 1_${ik}$, n+1 ),&
ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! could not swap because blocks not well separated
scale = one
est = bignum
else
! reordering successful
if( work( 2_${ik}$, 1_${ik}$ )==zero ) then
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
n2 = 1_${ik}$
nn = n - 1_${ik}$
else
! triangularize the 2 by 2 block by unitary
! transformation u = [ cs i*ss ]
! [ i*ss cs ].
! such that the (1,1) position of work is complex
! eigenvalue lambda with positive imaginary part. (2,2)
! position of work is the complex eigenvalue lambda
! with negative imaginary part.
mu = sqrt( abs( work( 1_${ik}$, 2_${ik}$ ) ) )*sqrt( abs( work( 2_${ik}$, 1_${ik}$ ) ) )
delta = stdlib${ii}$_dlapy2( mu, work( 2_${ik}$, 1_${ik}$ ) )
cs = mu / delta
sn = -work( 2_${ik}$, 1_${ik}$ ) / delta
! form
! c**t = work(2:n,2:n) + i*[rwork(1) ..... rwork(n-1) ]
! [ mu ]
! [ .. ]
! [ .. ]
! [ mu ]
! where c**t is transpose of matrix c,
! and rwork is stored starting in the n+1-st column of
! work.
do j = 3, n
work( 2_${ik}$, j ) = cs*work( 2_${ik}$, j )
work( j, j ) = work( j, j ) - work( 1_${ik}$, 1_${ik}$ )
end do
work( 2_${ik}$, 2_${ik}$ ) = zero
work( 1_${ik}$, n+1 ) = two*mu
do i = 2, n - 1
work( i, n+1 ) = sn*work( 1_${ik}$, i+1 )
end do
n2 = 2_${ik}$
nn = 2_${ik}$*( n-1 )
end if
! estimate norm(inv(c**t))
est = zero
kase = 0_${ik}$
50 continue
call stdlib${ii}$_dlacn2( nn, work( 1_${ik}$, n+2 ), work( 1_${ik}$, n+4 ), iwork,est, kase, &
isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c**t*x = scale*c.
call stdlib${ii}$_dlaqtr( .true., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy, &
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c**t*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_dlaqtr( .true., .false., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
else
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c*x = scale*c.
call stdlib${ii}$_dlaqtr( .false., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy,&
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_dlaqtr( .false., .false., n-1,work( 2_${ik}$, 2_${ik}$ ), ldwork,work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
end if
go to 50
end if
end if
sep( ks ) = scale / max( est, smlnum )
if( pair )sep( ks+1 ) = sep( ks )
end if
if( pair )ks = ks + 1_${ik}$
end do loop_60
return
end subroutine stdlib${ii}$_dtrsna
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$trsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, m, &
!! DTRSNA: estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a real upper
!! quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
!! orthogonal).
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
work, ldwork, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(out) :: s(*), sep(*), work(ldwork,*)
real(${rk}$), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
! =====================================================================
! Local Scalars
logical(lk) :: pair, somcon, wantbh, wants, wantsp
integer(${ik}$) :: i, ierr, ifst, ilst, j, k, kase, ks, n2, nn
real(${rk}$) :: bignum, cond, cs, delta, dumm, eps, est, lnrm, mu, prod, prod1, prod2, &
rnrm, scale, smlnum, sn
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(${rk}$) :: dummy(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else
! set m to the number of eigenpairs for which condition numbers
! are required, and test mm.
if( somcon ) then
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
else
m = n
end if
if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
ks = 0_${ik}$
pair = .false.
loop_60: do k = 1, n
! determine whether t(k,k) begins a 1-by-1 or 2-by-2 block.
if( pair ) then
pair = .false.
cycle loop_60
else
if( k<n )pair = t( k+1, k )/=zero
end if
! determine whether condition numbers are required for the k-th
! eigenpair.
if( somcon ) then
if( pair ) then
if( .not.select( k ) .and. .not.select( k+1 ) )cycle loop_60
else
if( .not.select( k ) )cycle loop_60
end if
end if
ks = ks + 1_${ik}$
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
if( .not.pair ) then
! real eigenvalue.
prod = stdlib${ii}$_${ri}$dot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
else
! complex eigenvalue.
prod1 = stdlib${ii}$_${ri}$dot( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
prod1 = prod1 + stdlib${ii}$_${ri}$dot( n, vr( 1_${ik}$, ks+1 ), 1_${ik}$, vl( 1_${ik}$, ks+1 ),1_${ik}$ )
prod2 = stdlib${ii}$_${ri}$dot( n, vl( 1_${ik}$, ks ), 1_${ik}$, vr( 1_${ik}$, ks+1 ), 1_${ik}$ )
prod2 = prod2 - stdlib${ii}$_${ri}$dot( n, vl( 1_${ik}$, ks+1 ), 1_${ik}$, vr( 1_${ik}$, ks ),1_${ik}$ )
rnrm = stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, vr( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
lnrm = stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, vl( &
1_${ik}$, ks+1 ), 1_${ik}$ ) )
cond = stdlib${ii}$_${ri}$lapy2( prod1, prod2 ) / ( rnrm*lnrm )
s( ks ) = cond
s( ks+1 ) = cond
end if
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the diagonal
! block beginning at t(k,k) to the (1,1) position.
call stdlib${ii}$_${ri}$lacpy( 'FULL', n, n, t, ldt, work, ldwork )
ifst = k
ilst = 1_${ik}$
call stdlib${ii}$_${ri}$trexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, ifst, ilst,work( 1_${ik}$, n+1 ),&
ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! could not swap because blocks not well separated
scale = one
est = bignum
else
! reordering successful
if( work( 2_${ik}$, 1_${ik}$ )==zero ) then
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
n2 = 1_${ik}$
nn = n - 1_${ik}$
else
! triangularize the 2 by 2 block by unitary
! transformation u = [ cs i*ss ]
! [ i*ss cs ].
! such that the (1,1) position of work is complex
! eigenvalue lambda with positive imaginary part. (2,2)
! position of work is the complex eigenvalue lambda
! with negative imaginary part.
mu = sqrt( abs( work( 1_${ik}$, 2_${ik}$ ) ) )*sqrt( abs( work( 2_${ik}$, 1_${ik}$ ) ) )
delta = stdlib${ii}$_${ri}$lapy2( mu, work( 2_${ik}$, 1_${ik}$ ) )
cs = mu / delta
sn = -work( 2_${ik}$, 1_${ik}$ ) / delta
! form
! c**t = work(2:n,2:n) + i*[rwork(1) ..... rwork(n-1) ]
! [ mu ]
! [ .. ]
! [ .. ]
! [ mu ]
! where c**t is transpose of matrix c,
! and rwork is stored starting in the n+1-st column of
! work.
do j = 3, n
work( 2_${ik}$, j ) = cs*work( 2_${ik}$, j )
work( j, j ) = work( j, j ) - work( 1_${ik}$, 1_${ik}$ )
end do
work( 2_${ik}$, 2_${ik}$ ) = zero
work( 1_${ik}$, n+1 ) = two*mu
do i = 2, n - 1
work( i, n+1 ) = sn*work( 1_${ik}$, i+1 )
end do
n2 = 2_${ik}$
nn = 2_${ik}$*( n-1 )
end if
! estimate norm(inv(c**t))
est = zero
kase = 0_${ik}$
50 continue
call stdlib${ii}$_${ri}$lacn2( nn, work( 1_${ik}$, n+2 ), work( 1_${ik}$, n+4 ), iwork,est, kase, &
isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c**t*x = scale*c.
call stdlib${ii}$_${ri}$laqtr( .true., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy, &
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c**t*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_${ri}$laqtr( .true., .false., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
else
if( n2==1_${ik}$ ) then
! real eigenvalue: solve c*x = scale*c.
call stdlib${ii}$_${ri}$laqtr( .false., .true., n-1, work( 2_${ik}$, 2_${ik}$ ),ldwork, dummy,&
dumm, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
else
! complex eigenvalue: solve
! c*(p+iq) = scale*(c+id) in real arithmetic.
call stdlib${ii}$_${ri}$laqtr( .false., .false., n-1,work( 2_${ik}$, 2_${ik}$ ), ldwork,work( &
1_${ik}$, n+1 ), mu, scale,work( 1_${ik}$, n+4 ), work( 1_${ik}$, n+6 ),ierr )
end if
end if
go to 50
end if
end if
sep( ks ) = scale / max( est, smlnum )
if( pair )sep( ks+1 ) = sep( ks )
end if
if( pair )ks = ks + 1_${ik}$
end do loop_60
return
end subroutine stdlib${ii}$_${ri}$trsna
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm,&
!! CTRSNA estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a complex upper triangular
!! matrix T (or of any matrix Q*T*Q**H with Q unitary).
m, work, ldwork, 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) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(sp), intent(out) :: rwork(*), s(*), sep(*)
complex(sp), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(sp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
logical(lk) :: somcon, wantbh, wants, wantsp
character :: normin
integer(${ik}$) :: i, ierr, ix, j, k, kase, ks
real(sp) :: bignum, eps, est, lnrm, rnrm, scale, smlnum, xnorm
complex(sp) :: cdum, prod
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
complex(sp) :: dummy(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
! set m to the number of eigenpairs for which condition numbers are
! to be computed.
if( somcon ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
ks = 1_${ik}$
loop_50: do k = 1, n
if( somcon ) then
if( .not.select( k ) )cycle loop_50
end if
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
prod = stdlib${ii}$_cdotc( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_scnrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_scnrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the k-th
! diagonal element to the (1,1) position.
call stdlib${ii}$_clacpy( 'FULL', n, n, t, ldt, work, ldwork )
call stdlib${ii}$_ctrexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, k, 1_${ik}$, ierr )
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
! estimate a lower bound for the 1-norm of inv(c**h). the 1st
! and (n+1)th columns of work are used to store work vectors.
sep( ks ) = zero
est = zero
kase = 0_${ik}$
normin = 'N'
30 continue
call stdlib${ii}$_clacn2( n-1, work( 1_${ik}$, n+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve c**h*x = scale*b
call stdlib${ii}$_clatrs( 'UPPER', 'CONJUGATE TRANSPOSE','NONUNIT', normin, n-1, &
work( 2_${ik}$, 2_${ik}$ ),ldwork, work, scale, rwork, ierr )
else
! solve c*x = scale*b
call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NONUNIT',normin, n-1, work( &
2_${ik}$, 2_${ik}$ ), ldwork, work,scale, rwork, ierr )
end if
normin = 'Y'
if( scale/=one ) then
! multiply by 1/scale if doing so will not cause
! overflow.
ix = stdlib${ii}$_icamax( n-1, work, 1_${ik}$ )
xnorm = cabs1( work( ix, 1_${ik}$ ) )
if( scale<xnorm*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_csrscl( n, scale, work, 1_${ik}$ )
end if
go to 30
end if
sep( ks ) = one / max( est, smlnum )
end if
40 continue
ks = ks + 1_${ik}$
end do loop_50
return
end subroutine stdlib${ii}$_ctrsna
pure module subroutine stdlib${ii}$_ztrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm,&
!! ZTRSNA estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a complex upper triangular
!! matrix T (or of any matrix Q*T*Q**H with Q unitary).
m, work, ldwork, 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) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(dp), intent(out) :: rwork(*), s(*), sep(*)
complex(dp), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(dp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
logical(lk) :: somcon, wantbh, wants, wantsp
character :: normin
integer(${ik}$) :: i, ierr, ix, j, k, kase, ks
real(dp) :: bignum, eps, est, lnrm, rnrm, scale, smlnum, xnorm
complex(dp) :: cdum, prod
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
complex(dp) :: dummy(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
! set m to the number of eigenpairs for which condition numbers are
! to be computed.
if( somcon ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
ks = 1_${ik}$
loop_50: do k = 1, n
if( somcon ) then
if( .not.select( k ) )cycle loop_50
end if
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
prod = stdlib${ii}$_zdotc( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_dznrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_dznrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the k-th
! diagonal element to the (1,1) position.
call stdlib${ii}$_zlacpy( 'FULL', n, n, t, ldt, work, ldwork )
call stdlib${ii}$_ztrexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, k, 1_${ik}$, ierr )
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
! estimate a lower bound for the 1-norm of inv(c**h). the 1st
! and (n+1)th columns of work are used to store work vectors.
sep( ks ) = zero
est = zero
kase = 0_${ik}$
normin = 'N'
30 continue
call stdlib${ii}$_zlacn2( n-1, work( 1_${ik}$, n+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve c**h*x = scale*b
call stdlib${ii}$_zlatrs( 'UPPER', 'CONJUGATE TRANSPOSE','NONUNIT', normin, n-1, &
work( 2_${ik}$, 2_${ik}$ ),ldwork, work, scale, rwork, ierr )
else
! solve c*x = scale*b
call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NONUNIT',normin, n-1, work( &
2_${ik}$, 2_${ik}$ ), ldwork, work,scale, rwork, ierr )
end if
normin = 'Y'
if( scale/=one ) then
! multiply by 1/scale if doing so will not cause
! overflow.
ix = stdlib${ii}$_izamax( n-1, work, 1_${ik}$ )
xnorm = cabs1( work( ix, 1_${ik}$ ) )
if( scale<xnorm*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_zdrscl( n, scale, work, 1_${ik}$ )
end if
go to 30
end if
sep( ks ) = one / max( est, smlnum )
end if
40 continue
ks = ks + 1_${ik}$
end do loop_50
return
end subroutine stdlib${ii}$_ztrsna
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm,&
!! ZTRSNA: estimates reciprocal condition numbers for specified
!! eigenvalues and/or right eigenvectors of a complex upper triangular
!! matrix T (or of any matrix Q*T*Q**H with Q unitary).
m, work, ldwork, 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) :: howmny, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, ldwork, mm, n
! Array Arguments
logical(lk), intent(in) :: select(*)
real(${ck}$), intent(out) :: rwork(*), s(*), sep(*)
complex(${ck}$), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*)
complex(${ck}$), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
logical(lk) :: somcon, wantbh, wants, wantsp
character :: normin
integer(${ik}$) :: i, ierr, ix, j, k, kase, ks
real(${ck}$) :: bignum, eps, est, lnrm, rnrm, scale, smlnum, xnorm
complex(${ck}$) :: cdum, prod
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
complex(${ck}$) :: dummy(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
somcon = stdlib_lsame( howmny, 'S' )
! set m to the number of eigenpairs for which condition numbers are
! to be computed.
if( somcon ) then
m = 0_${ik}$
do j = 1, n
if( select( j ) )m = m + 1_${ik}$
end do
else
m = n
end if
info = 0_${ik}$
if( .not.wants .and. .not.wantsp ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvl<1_${ik}$ .or. ( wants .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wants .and. ldvr<n ) ) then
info = -10_${ik}$
else if( mm<m ) then
info = -13_${ik}$
else if( ldwork<1_${ik}$ .or. ( wantsp .and. ldwork<n ) ) then
info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSNA', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( somcon ) then
if( .not.select( 1 ) )return
end if
if( wants )s( 1_${ik}$ ) = one
if( wantsp )sep( 1_${ik}$ ) = abs( t( 1_${ik}$, 1_${ik}$ ) )
return
end if
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / eps
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
ks = 1_${ik}$
loop_50: do k = 1, n
if( somcon ) then
if( .not.select( k ) )cycle loop_50
end if
if( wants ) then
! compute the reciprocal condition number of the k-th
! eigenvalue.
prod = stdlib${ii}$_${ci}$dotc( n, vr( 1_${ik}$, ks ), 1_${ik}$, vl( 1_${ik}$, ks ), 1_${ik}$ )
rnrm = stdlib${ii}$_${c2ri(ci)}$znrm2( n, vr( 1_${ik}$, ks ), 1_${ik}$ )
lnrm = stdlib${ii}$_${c2ri(ci)}$znrm2( n, vl( 1_${ik}$, ks ), 1_${ik}$ )
s( ks ) = abs( prod ) / ( rnrm*lnrm )
end if
if( wantsp ) then
! estimate the reciprocal condition number of the k-th
! eigenvector.
! copy the matrix t to the array work and swap the k-th
! diagonal element to the (1,1) position.
call stdlib${ii}$_${ci}$lacpy( 'FULL', n, n, t, ldt, work, ldwork )
call stdlib${ii}$_${ci}$trexc( 'NO Q', n, work, ldwork, dummy, 1_${ik}$, k, 1_${ik}$, ierr )
! form c = t22 - lambda*i in work(2:n,2:n).
do i = 2, n
work( i, i ) = work( i, i ) - work( 1_${ik}$, 1_${ik}$ )
end do
! estimate a lower bound for the 1-norm of inv(c**h). the 1st
! and (n+1)th columns of work are used to store work vectors.
sep( ks ) = zero
est = zero
kase = 0_${ik}$
normin = 'N'
30 continue
call stdlib${ii}$_${ci}$lacn2( n-1, work( 1_${ik}$, n+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve c**h*x = scale*b
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE','NONUNIT', normin, n-1, &
work( 2_${ik}$, 2_${ik}$ ),ldwork, work, scale, rwork, ierr )
else
! solve c*x = scale*b
call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NONUNIT',normin, n-1, work( &
2_${ik}$, 2_${ik}$ ), ldwork, work,scale, rwork, ierr )
end if
normin = 'Y'
if( scale/=one ) then
! multiply by 1/scale if doing so will not cause
! overflow.
ix = stdlib${ii}$_i${ci}$amax( n-1, work, 1_${ik}$ )
xnorm = cabs1( work( ix, 1_${ik}$ ) )
if( scale<xnorm*smlnum .or. scale==zero )go to 40
call stdlib${ii}$_${ci}$drscl( n, scale, work, 1_${ik}$ )
end if
go to 30
end if
sep( ks ) = one / max( est, smlnum )
end if
40 continue
ks = ks + 1_${ik}$
end do loop_50
return
end subroutine stdlib${ii}$_${ci}$trsna
#:endif
#:endfor
module subroutine stdlib${ii}$_strexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info )
!! STREXC reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!! moved to row ILST.
!! The real Schur form T is reordered by an orthogonal similarity
!! transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!! is updated by postmultiplying it with Z.
!! T must be in Schur canonical form (as returned by SHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack 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) :: compq
integer(${ik}$), intent(inout) :: ifst, ilst
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldq, ldt, n
! Array Arguments
real(sp), intent(inout) :: q(ldq,*), t(ldt,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: here, nbf, nbl, nbnext
! Intrinsic Functions
! Executable Statements
! decode and test the input arguments.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.wantq .and. .not.stdlib_lsame( compq, 'N' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STREXC', -info )
return
end if
! quick return if possible
if( n<=1 )return
! determine the first row of specified block
! and find out it is 1 by 1 or 2 by 2.
if( ifst>1_${ik}$ ) then
if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$
end if
nbf = 1_${ik}$
if( ifst<n ) then
if( t( ifst+1, ifst )/=zero )nbf = 2_${ik}$
end if
! determine the first row of the final block
! and find out it is 1 by 1 or 2 by 2.
if( ilst>1_${ik}$ ) then
if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$
end if
nbl = 1_${ik}$
if( ilst<n ) then
if( t( ilst+1, ilst )/=zero )nbl = 2_${ik}$
end if
if( ifst==ilst )return
if( ifst<ilst ) then
! update ilst
if( nbf==2_${ik}$ .and. nbl==1_${ik}$ )ilst = ilst - 1_${ik}$
if( nbf==1_${ik}$ .and. nbl==2_${ik}$ )ilst = ilst + 1_${ik}$
here = ifst
10 continue
! swap block with next one below
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here+nbf+1<=n ) then
if( t( here+nbf+1, here+nbf )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here+3<=n ) then
if( t( here+3, here+2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, nbnext,work, info )
here = here + 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here+2, here+1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$,nbnext, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, 1_${ik}$,work, info )
here = here + 2_${ik}$
end if
end if
end if
if( here<ilst )go to 10
else
here = ifst
20 continue
! swap block with next one above
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, &
info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info )
here = here - 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here, here-1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info )
here = here - 2_${ik}$
end if
end if
end if
if( here>ilst )go to 20
end if
ilst = here
return
end subroutine stdlib${ii}$_strexc
module subroutine stdlib${ii}$_dtrexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info )
!! DTREXC reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!! moved to row ILST.
!! The real Schur form T is reordered by an orthogonal similarity
!! transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!! is updated by postmultiplying it with Z.
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack 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) :: compq
integer(${ik}$), intent(inout) :: ifst, ilst
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldq, ldt, n
! Array Arguments
real(dp), intent(inout) :: q(ldq,*), t(ldt,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: here, nbf, nbl, nbnext
! Intrinsic Functions
! Executable Statements
! decode and test the input arguments.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.wantq .and. .not.stdlib_lsame( compq, 'N' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREXC', -info )
return
end if
! quick return if possible
if( n<=1 )return
! determine the first row of specified block
! and find out it is 1 by 1 or 2 by 2.
if( ifst>1_${ik}$ ) then
if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$
end if
nbf = 1_${ik}$
if( ifst<n ) then
if( t( ifst+1, ifst )/=zero )nbf = 2_${ik}$
end if
! determine the first row of the final block
! and find out it is 1 by 1 or 2 by 2.
if( ilst>1_${ik}$ ) then
if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$
end if
nbl = 1_${ik}$
if( ilst<n ) then
if( t( ilst+1, ilst )/=zero )nbl = 2_${ik}$
end if
if( ifst==ilst )return
if( ifst<ilst ) then
! update ilst
if( nbf==2_${ik}$ .and. nbl==1_${ik}$ )ilst = ilst - 1_${ik}$
if( nbf==1_${ik}$ .and. nbl==2_${ik}$ )ilst = ilst + 1_${ik}$
here = ifst
10 continue
! swap block with next one below
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here+nbf+1<=n ) then
if( t( here+nbf+1, here+nbf )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here+3<=n ) then
if( t( here+3, here+2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, nbnext,work, info )
here = here + 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here+2, here+1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$,nbnext, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, 1_${ik}$,work, info )
here = here + 2_${ik}$
end if
end if
end if
if( here<ilst )go to 10
else
here = ifst
20 continue
! swap block with next one above
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, &
info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info )
here = here - 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here, here-1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info )
here = here - 2_${ik}$
end if
end if
end if
if( here>ilst )go to 20
end if
ilst = here
return
end subroutine stdlib${ii}$_dtrexc
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$trexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info )
!! DTREXC: reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!! moved to row ILST.
!! The real Schur form T is reordered by an orthogonal similarity
!! transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!! is updated by postmultiplying it with Z.
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compq
integer(${ik}$), intent(inout) :: ifst, ilst
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldq, ldt, n
! Array Arguments
real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: here, nbf, nbl, nbnext
! Intrinsic Functions
! Executable Statements
! decode and test the input arguments.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.wantq .and. .not.stdlib_lsame( compq, 'N' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTREXC', -info )
return
end if
! quick return if possible
if( n<=1 )return
! determine the first row of specified block
! and find out it is 1 by 1 or 2 by 2.
if( ifst>1_${ik}$ ) then
if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$
end if
nbf = 1_${ik}$
if( ifst<n ) then
if( t( ifst+1, ifst )/=zero )nbf = 2_${ik}$
end if
! determine the first row of the final block
! and find out it is 1 by 1 or 2 by 2.
if( ilst>1_${ik}$ ) then
if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$
end if
nbl = 1_${ik}$
if( ilst<n ) then
if( t( ilst+1, ilst )/=zero )nbl = 2_${ik}$
end if
if( ifst==ilst )return
if( ifst<ilst ) then
! update ilst
if( nbf==2_${ik}$ .and. nbl==1_${ik}$ )ilst = ilst - 1_${ik}$
if( nbf==1_${ik}$ .and. nbl==2_${ik}$ )ilst = ilst + 1_${ik}$
here = ifst
10 continue
! swap block with next one below
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here+nbf+1<=n ) then
if( t( here+nbf+1, here+nbf )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here+3<=n ) then
if( t( here+3, here+2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, nbnext,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, nbnext,work, info )
here = here + 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here+2, here+1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$,nbnext, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here + 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here+1, 1_${ik}$, 1_${ik}$,work, info )
here = here + 2_${ik}$
end if
end if
end if
if( here<ilst )go to 10
else
here = ifst
20 continue
! swap block with next one above
if( nbf==1_${ik}$ .or. nbf==2_${ik}$ ) then
! current block either 1 by 1 or 2 by 2
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, &
info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - nbnext
! test if 2 by 2 block breaks into two 1 by 1 blocks
if( nbf==2_${ik}$ ) then
if( t( here+1, here )==zero )nbf = 3_${ik}$
end if
else
! current block consists of two 1 by 1 blocks each of which
! must be swapped individually
nbnext = 1_${ik}$
if( here>=3_${ik}$ ) then
if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$
end if
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
if( nbnext==1_${ik}$ ) then
! swap two 1 by 1 blocks, no problems possible
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info )
here = here - 1_${ik}$
else
! recompute nbnext in case 2 by 2 split
if( t( here, here-1 )==zero )nbnext = 1_${ik}$
if( nbnext==2_${ik}$ ) then
! 2 by 2 block did not split
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info )
if( info/=0_${ik}$ ) then
ilst = here
return
end if
here = here - 2_${ik}$
else
! 2 by 2 block did split
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info )
call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info )
here = here - 2_${ik}$
end if
end if
end if
if( here>ilst )go to 20
end if
ilst = here
return
end subroutine stdlib${ii}$_${ri}$trexc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctrexc( compq, n, t, ldt, q, ldq, ifst, ilst, info )
!! CTREXC reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that the diagonal element of T with row index IFST
!! is moved to row ILST.
!! The Schur form T is reordered by a unitary similarity transformation
!! Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
!! postmultplying it with Z.
! -- lapack computational routine --
! -- lapack 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) :: compq
integer(${ik}$), intent(in) :: ifst, ilst, ldq, ldt, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(sp), intent(inout) :: q(ldq,*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: k, m1, m2, m3
real(sp) :: cs
complex(sp) :: sn, t11, t22, temp
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTREXC', -info )
return
end if
! quick return if possible
if( n<=1 .or. ifst==ilst )return
if( ifst<ilst ) then
! move the ifst-th diagonal element forward down the diagonal.
m1 = 0_${ik}$
m2 = -1_${ik}$
m3 = 1_${ik}$
else
! move the ifst-th diagonal element backward up the diagonal.
m1 = -1_${ik}$
m2 = 0_${ik}$
m3 = -1_${ik}$
end if
do k = ifst + m1, ilst + m2, m3
! interchange the k-th and (k+1)-th diagonal elements.
t11 = t( k, k )
t22 = t( k+1, k+1 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_clartg( t( k, k+1 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( k+2<=n )call stdlib${ii}$_crot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,sn )
call stdlib${ii}$_crot( k-1, t( 1_${ik}$, k ), 1_${ik}$, t( 1_${ik}$, k+1 ), 1_${ik}$, cs, conjg( sn ) )
t( k, k ) = t22
t( k+1, k+1 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_crot( n, q( 1_${ik}$, k ), 1_${ik}$, q( 1_${ik}$, k+1 ), 1_${ik}$, cs,conjg( sn ) )
end if
end do
return
end subroutine stdlib${ii}$_ctrexc
pure module subroutine stdlib${ii}$_ztrexc( compq, n, t, ldt, q, ldq, ifst, ilst, info )
!! ZTREXC reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that the diagonal element of T with row index IFST
!! is moved to row ILST.
!! The Schur form T is reordered by a unitary similarity transformation
!! Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
!! postmultplying it with Z.
! -- lapack computational routine --
! -- lapack 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) :: compq
integer(${ik}$), intent(in) :: ifst, ilst, ldq, ldt, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(dp), intent(inout) :: q(ldq,*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: k, m1, m2, m3
real(dp) :: cs
complex(dp) :: sn, t11, t22, temp
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREXC', -info )
return
end if
! quick return if possible
if( n<=1 .or. ifst==ilst )return
if( ifst<ilst ) then
! move the ifst-th diagonal element forward down the diagonal.
m1 = 0_${ik}$
m2 = -1_${ik}$
m3 = 1_${ik}$
else
! move the ifst-th diagonal element backward up the diagonal.
m1 = -1_${ik}$
m2 = 0_${ik}$
m3 = -1_${ik}$
end if
do k = ifst + m1, ilst + m2, m3
! interchange the k-th and (k+1)-th diagonal elements.
t11 = t( k, k )
t22 = t( k+1, k+1 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_zlartg( t( k, k+1 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( k+2<=n )call stdlib${ii}$_zrot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,sn )
call stdlib${ii}$_zrot( k-1, t( 1_${ik}$, k ), 1_${ik}$, t( 1_${ik}$, k+1 ), 1_${ik}$, cs,conjg( sn ) )
t( k, k ) = t22
t( k+1, k+1 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_zrot( n, q( 1_${ik}$, k ), 1_${ik}$, q( 1_${ik}$, k+1 ), 1_${ik}$, cs,conjg( sn ) )
end if
end do
return
end subroutine stdlib${ii}$_ztrexc
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$trexc( compq, n, t, ldt, q, ldq, ifst, ilst, info )
!! ZTREXC: reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that the diagonal element of T with row index IFST
!! is moved to row ILST.
!! The Schur form T is reordered by a unitary similarity transformation
!! Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
!! postmultplying it with Z.
! -- lapack computational routine --
! -- lapack 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) :: compq
integer(${ik}$), intent(in) :: ifst, ilst, ldq, ldt, n
integer(${ik}$), intent(out) :: info
! Array Arguments
complex(${ck}$), intent(inout) :: q(ldq,*), t(ldt,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantq
integer(${ik}$) :: k, m1, m2, m3
real(${ck}$) :: cs
complex(${ck}$) :: sn, t11, t22, temp
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
info = 0_${ik}$
wantq = stdlib_lsame( compq, 'V' )
if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
else if(( ifst<1_${ik}$ .or. ifst>n ).and.( n>0_${ik}$ )) then
info = -7_${ik}$
else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTREXC', -info )
return
end if
! quick return if possible
if( n<=1 .or. ifst==ilst )return
if( ifst<ilst ) then
! move the ifst-th diagonal element forward down the diagonal.
m1 = 0_${ik}$
m2 = -1_${ik}$
m3 = 1_${ik}$
else
! move the ifst-th diagonal element backward up the diagonal.
m1 = -1_${ik}$
m2 = 0_${ik}$
m3 = -1_${ik}$
end if
do k = ifst + m1, ilst + m2, m3
! interchange the k-th and (k+1)-th diagonal elements.
t11 = t( k, k )
t22 = t( k+1, k+1 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_${ci}$lartg( t( k, k+1 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( k+2<=n )call stdlib${ii}$_${ci}$rot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,sn )
call stdlib${ii}$_${ci}$rot( k-1, t( 1_${ik}$, k ), 1_${ik}$, t( 1_${ik}$, k+1 ), 1_${ik}$, cs,conjg( sn ) )
t( k, k ) = t22
t( k+1, k+1 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_${ci}$rot( n, q( 1_${ik}$, k ), 1_${ik}$, q( 1_${ik}$, k+1 ), 1_${ik}$, cs,conjg( sn ) )
end if
end do
return
end subroutine stdlib${ii}$_${ci}$trexc
#:endif
#:endfor
module subroutine stdlib${ii}$_strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, &
!! STRSEN reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!! the leading diagonal blocks of the upper quasi-triangular matrix T,
!! and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
!! T must be in Schur canonical form (as returned by SHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
lwork, iwork, liwork, 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) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, liwork, lwork, n
real(sp), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: q(ldq,*), t(ldt,*)
real(sp), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn
real(sp) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else
! set m to the dimension of the specified invariant subspace,
! and test lwork and liwork.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
n1 = m
n2 = n - m
nn = n1*n2
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
liwmin = max( 1_${ik}$, nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = max( 1_${ik}$, n )
liwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
liwmin = 1_${ik}$
end if
if( lwork<lwmin .and. .not.lquery ) then
info = -15_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -17_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'STRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_slange( '1', n, n, t, ldt, work )
go to 40
end if
! collect the selected blocks at the top-left corner of t.
ks = 0_${ik}$
pair = .false.
loop_20: do k = 1, n
if( pair ) then
pair = .false.
else
swap = select( k )
if( k<n ) then
if( t( k+1, k )/=zero ) then
pair = .true.
swap = swap .or. select( k+1 )
end if
end if
if( swap ) then
ks = ks + 1_${ik}$
! swap the k-th block to position ks.
ierr = 0_${ik}$
kk = k
if( k/=ks )call stdlib${ii}$_strexc( compq, n, t, ldt, q, ldq, kk, ks, work,ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! blocks too close to swap: exit.
info = 1_${ik}$
if( wants )s = zero
if( wantsp )sep = zero
go to 40
end if
if( pair )ks = ks + 1_${ik}$
end if
end if
end do loop_20
if( wants ) then
! solve sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_slacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_strsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_slange( 'F', n1, n2, work, n1, work )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_slacn2( nn, work( nn+1 ), work, iwork, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_strsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**t*r - r*t22**t = scale*x.
call stdlib${ii}$_strsyl( 'T', 'T', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! store the output eigenvalues in wr and wi.
do k = 1, n
wr( k ) = t( k, k )
wi( k ) = zero
end do
do k = 1, n - 1
if( t( k+1, k )/=zero ) then
wi( k ) = sqrt( abs( t( k, k+1 ) ) )*sqrt( abs( t( k+1, k ) ) )
wi( k+1 ) = -wi( k )
end if
end do
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_strsen
module subroutine stdlib${ii}$_dtrsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, &
!! DTRSEN reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!! the leading diagonal blocks of the upper quasi-triangular matrix T,
!! and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
lwork, iwork, liwork, 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) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, liwork, lwork, n
real(dp), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: q(ldq,*), t(ldt,*)
real(dp), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn
real(dp) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else
! set m to the dimension of the specified invariant subspace,
! and test lwork and liwork.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
n1 = m
n2 = n - m
nn = n1*n2
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
liwmin = max( 1_${ik}$, nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = max( 1_${ik}$, n )
liwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
liwmin = 1_${ik}$
end if
if( lwork<lwmin .and. .not.lquery ) then
info = -15_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -17_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_dlange( '1', n, n, t, ldt, work )
go to 40
end if
! collect the selected blocks at the top-left corner of t.
ks = 0_${ik}$
pair = .false.
loop_20: do k = 1, n
if( pair ) then
pair = .false.
else
swap = select( k )
if( k<n ) then
if( t( k+1, k )/=zero ) then
pair = .true.
swap = swap .or. select( k+1 )
end if
end if
if( swap ) then
ks = ks + 1_${ik}$
! swap the k-th block to position ks.
ierr = 0_${ik}$
kk = k
if( k/=ks )call stdlib${ii}$_dtrexc( compq, n, t, ldt, q, ldq, kk, ks, work,ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! blocks too close to swap: exit.
info = 1_${ik}$
if( wants )s = zero
if( wantsp )sep = zero
go to 40
end if
if( pair )ks = ks + 1_${ik}$
end if
end if
end do loop_20
if( wants ) then
! solve sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_dlacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_dtrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_dlange( 'F', n1, n2, work, n1, work )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_dlacn2( nn, work( nn+1 ), work, iwork, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_dtrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**t*r - r*t22**t = scale*x.
call stdlib${ii}$_dtrsyl( 'T', 'T', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! store the output eigenvalues in wr and wi.
do k = 1, n
wr( k ) = t( k, k )
wi( k ) = zero
end do
do k = 1, n - 1
if( t( k+1, k )/=zero ) then
wi( k ) = sqrt( abs( t( k, k+1 ) ) )*sqrt( abs( t( k+1, k ) ) )
wi( k+1 ) = -wi( k )
end if
end do
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dtrsen
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$trsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, &
!! DTRSEN: reorders the real Schur factorization of a real matrix
!! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!! the leading diagonal blocks of the upper quasi-triangular matrix T,
!! and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
!! T must be in Schur canonical form (as returned by DHSEQR), that is,
!! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!! 2-by-2 diagonal block has its diagonal elements equal and its
!! off-diagonal elements of opposite sign.
lwork, iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, liwork, lwork, n
real(${rk}$), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*)
real(${rk}$), intent(out) :: wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn
real(${rk}$) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else
! set m to the dimension of the specified invariant subspace,
! and test lwork and liwork.
m = 0_${ik}$
pair = .false.
do k = 1, n
if( pair ) then
pair = .false.
else
if( k<n ) then
if( t( k+1, k )==zero ) then
if( select( k ) )m = m + 1_${ik}$
else
pair = .true.
if( select( k ) .or. select( k+1 ) )m = m + 2_${ik}$
end if
else
if( select( n ) )m = m + 1_${ik}$
end if
end if
end do
n1 = m
n2 = n - m
nn = n1*n2
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
liwmin = max( 1_${ik}$, nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = max( 1_${ik}$, n )
liwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
liwmin = 1_${ik}$
end if
if( lwork<lwmin .and. .not.lquery ) then
info = -15_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -17_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DTRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible.
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_${ri}$lange( '1', n, n, t, ldt, work )
go to 40
end if
! collect the selected blocks at the top-left corner of t.
ks = 0_${ik}$
pair = .false.
loop_20: do k = 1, n
if( pair ) then
pair = .false.
else
swap = select( k )
if( k<n ) then
if( t( k+1, k )/=zero ) then
pair = .true.
swap = swap .or. select( k+1 )
end if
end if
if( swap ) then
ks = ks + 1_${ik}$
! swap the k-th block to position ks.
ierr = 0_${ik}$
kk = k
if( k/=ks )call stdlib${ii}$_${ri}$trexc( compq, n, t, ldt, q, ldq, kk, ks, work,ierr )
if( ierr==1_${ik}$ .or. ierr==2_${ik}$ ) then
! blocks too close to swap: exit.
info = 1_${ik}$
if( wants )s = zero
if( wantsp )sep = zero
go to 40
end if
if( pair )ks = ks + 1_${ik}$
end if
end if
end do loop_20
if( wants ) then
! solve sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_${ri}$lacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_${ri}$trsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_${ri}$lange( 'F', n1, n2, work, n1, work )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ri}$lacn2( nn, work( nn+1 ), work, iwork, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_${ri}$trsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**t*r - r*t22**t = scale*x.
call stdlib${ii}$_${ri}$trsyl( 'T', 'T', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! store the output eigenvalues in wr and wi.
do k = 1, n
wr( k ) = t( k, k )
wi( k ) = zero
end do
do k = 1, n - 1
if( t( k+1, k )/=zero ) then
wi( k ) = sqrt( abs( t( k, k+1 ) ) )*sqrt( abs( t( k+1, k ) ) )
wi( k+1 ) = -wi( k )
end if
end do
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$trsen
#:endif
#:endfor
module subroutine stdlib${ii}$_ctrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, &
!! CTRSEN reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
!! the leading positions on the diagonal of the upper triangular matrix
!! T, and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
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) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, lwork, n
real(sp), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
complex(sp), intent(inout) :: q(ldq,*), t(ldt,*)
complex(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, ks, lwmin, n1, n2, nn
real(sp) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(sp) :: rwork(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
! set m to the number of selected eigenvalues.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
n1 = m
n2 = n - m
nn = n1*n2
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
end if
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CTRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_clange( '1', n, n, t, ldt, rwork )
go to 40
end if
! collect the selected eigenvalues at the top left corner of t.
ks = 0_${ik}$
do k = 1, n
if( select( k ) ) then
ks = ks + 1_${ik}$
! swap the k-th eigenvalue to position ks.
if( k/=ks )call stdlib${ii}$_ctrexc( compq, n, t, ldt, q, ldq, k, ks, ierr )
end if
end do
if( wants ) then
! solve the sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_clacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_ctrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_clange( 'F', n1, n2, work, n1, rwork )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_clacn2( nn, work( nn+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_ctrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**h*r - r*t22**h = scale*x.
call stdlib${ii}$_ctrsyl( 'C', 'C', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! copy reordered eigenvalues to w.
do k = 1, n
w( k ) = t( k, k )
end do
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_ctrsen
module subroutine stdlib${ii}$_ztrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, &
!! ZTRSEN reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
!! the leading positions on the diagonal of the upper triangular matrix
!! T, and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
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) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, lwork, n
real(dp), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
complex(dp), intent(inout) :: q(ldq,*), t(ldt,*)
complex(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, ks, lwmin, n1, n2, nn
real(dp) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(dp) :: rwork(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
! set m to the number of selected eigenvalues.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
n1 = m
n2 = n - m
nn = n1*n2
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
end if
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_zlange( '1', n, n, t, ldt, rwork )
go to 40
end if
! collect the selected eigenvalues at the top left corner of t.
ks = 0_${ik}$
do k = 1, n
if( select( k ) ) then
ks = ks + 1_${ik}$
! swap the k-th eigenvalue to position ks.
if( k/=ks )call stdlib${ii}$_ztrexc( compq, n, t, ldt, q, ldq, k, ks, ierr )
end if
end do
if( wants ) then
! solve the sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_zlacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_ztrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_zlange( 'F', n1, n2, work, n1, rwork )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_zlacn2( nn, work( nn+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_ztrsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**h*r - r*t22**h = scale*x.
call stdlib${ii}$_ztrsyl( 'C', 'C', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! copy reordered eigenvalues to w.
do k = 1, n
w( k ) = t( k, k )
end do
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_ztrsen
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$trsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, &
!! ZTRSEN: reorders the Schur factorization of a complex matrix
!! A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
!! the leading positions on the diagonal of the upper triangular matrix
!! T, and the leading columns of Q form an orthonormal basis of the
!! corresponding right invariant subspace.
!! Optionally the routine computes the reciprocal condition numbers of
!! the cluster of eigenvalues and/or the invariant subspace.
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) :: compq, job
integer(${ik}$), intent(out) :: info, m
integer(${ik}$), intent(in) :: ldq, ldt, lwork, n
real(${ck}$), intent(out) :: s, sep
! Array Arguments
logical(lk), intent(in) :: select(*)
complex(${ck}$), intent(inout) :: q(ldq,*), t(ldt,*)
complex(${ck}$), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantbh, wantq, wants, wantsp
integer(${ik}$) :: ierr, k, kase, ks, lwmin, n1, n2, nn
real(${ck}$) :: est, rnorm, scale
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
real(${ck}$) :: rwork(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode and test the input parameters.
wantbh = stdlib_lsame( job, 'B' )
wants = stdlib_lsame( job, 'E' ) .or. wantbh
wantsp = stdlib_lsame( job, 'V' ) .or. wantbh
wantq = stdlib_lsame( compq, 'V' )
! set m to the number of selected eigenvalues.
m = 0_${ik}$
do k = 1, n
if( select( k ) )m = m + 1_${ik}$
end do
n1 = m
n2 = n - m
nn = n1*n2
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( wantsp ) then
lwmin = max( 1_${ik}$, 2_${ik}$*nn )
else if( stdlib_lsame( job, 'N' ) ) then
lwmin = 1_${ik}$
else if( stdlib_lsame( job, 'E' ) ) then
lwmin = max( 1_${ik}$, nn )
end if
if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then
info = -1_${ik}$
else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldt<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldq<1_${ik}$ .or. ( wantq .and. ldq<n ) ) then
info = -8_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZTRSEN', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==n .or. m==0_${ik}$ ) then
if( wants )s = one
if( wantsp )sep = stdlib${ii}$_${ci}$lange( '1', n, n, t, ldt, rwork )
go to 40
end if
! collect the selected eigenvalues at the top left corner of t.
ks = 0_${ik}$
do k = 1, n
if( select( k ) ) then
ks = ks + 1_${ik}$
! swap the k-th eigenvalue to position ks.
if( k/=ks )call stdlib${ii}$_${ci}$trexc( compq, n, t, ldt, q, ldq, k, ks, ierr )
end if
end do
if( wants ) then
! solve the sylvester equation for r:
! t11*r - r*t22 = scale*t12
call stdlib${ii}$_${ci}$lacpy( 'F', n1, n2, t( 1_${ik}$, n1+1 ), ldt, work, n1 )
call stdlib${ii}$_${ci}$trsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, &
scale, ierr )
! estimate the reciprocal of the condition number of the cluster
! of eigenvalues.
rnorm = stdlib${ii}$_${ci}$lange( 'F', n1, n2, work, n1, rwork )
if( rnorm==zero ) then
s = one
else
s = scale / ( sqrt( scale*scale / rnorm+rnorm )*sqrt( rnorm ) )
end if
end if
if( wantsp ) then
! estimate sep(t11,t22).
est = zero
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ci}$lacn2( nn, work( nn+1 ), work, est, kase, isave )
if( kase/=0_${ik}$ ) then
if( kase==1_${ik}$ ) then
! solve t11*r - r*t22 = scale*x.
call stdlib${ii}$_${ci}$trsyl( 'N', 'N', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
else
! solve t11**h*r - r*t22**h = scale*x.
call stdlib${ii}$_${ci}$trsyl( 'C', 'C', -1_${ik}$, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, &
n1, scale,ierr )
end if
go to 30
end if
sep = scale / est
end if
40 continue
! copy reordered eigenvalues to w.
do k = 1, n
w( k ) = t( k, k )
end do
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_${ci}$trsen
#:endif
#:endfor
module subroutine stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info )
!! SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
!! an upper quasi-triangular matrix T by an orthogonal similarity
!! transformation.
!! T must be in Schur canonical form, that is, block upper triangular
!! with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
!! has its diagonal elements equal and its off-diagonal elements of
!! opposite sign.
! -- 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
logical(lk), intent(in) :: wantq
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: j1, ldq, ldt, n, n1, n2
! Array Arguments
real(sp), intent(inout) :: q(ldq,*), t(ldt,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ldd = 4_${ik}$
integer(${ik}$), parameter :: ldx = 2_${ik}$
! Local Scalars
integer(${ik}$) :: ierr, j2, j3, j4, k, nd
real(sp) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, &
thresh, wi1, wi2, wr1, wr2, xnorm
! Local Arrays
real(sp) :: d(ldd,4_${ik}$), u(3_${ik}$), u1(3_${ik}$), u2(3_${ik}$), x(ldx,2_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 .or. n1==0 .or. n2==0 )return
if( j1+n1>n )return
j2 = j1 + 1_${ik}$
j3 = j1 + 2_${ik}$
j4 = j1 + 3_${ik}$
if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then
! swap two 1-by-1 blocks.
t11 = t( j1, j1 )
t22 = t( j2, j2 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_slartg( t( j1, j2 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( j3<=n )call stdlib${ii}$_srot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn )
call stdlib${ii}$_srot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
t( j1, j1 ) = t22
t( j2, j2 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_srot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
else
! swapping involves at least one 2-by-2 block.
! copy the diagonal block of order n1+n2 to the local array d
! and compute its norm.
nd = n1 + n2
call stdlib${ii}$_slacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd )
dnorm = stdlib${ii}$_slange( 'MAX', nd, nd, d, ldd, work )
! compute machine-dependent threshold for test for accepting
! swap.
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' ) / eps
thresh = max( ten*eps*dnorm, smlnum )
! solve t11*x - x*t22 = scale*t12 for x.
call stdlib${ii}$_slasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,&
n1+1 ), ldd, scale, x,ldx, xnorm, ierr )
! swap the adjacent diagonal blocks.
k = n1 + n1 + n2 - 3_${ik}$
go to ( 10, 20, 30 )k
10 continue
! n1 = 1, n2 = 2: generate elementary reflector h so that:
! ( scale, x11, x12 ) h = ( 0, 0, * )
u( 1_${ik}$ ) = scale
u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )
call stdlib${ii}$_slarfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau )
u( 3_${ik}$ ) = one
t11 = t( j1, j1 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_slarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
call stdlib${ii}$_slarfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j3, j3 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
20 continue
! n1 = 2, n2 = 1: generate elementary reflector h so that:
! h ( -x11 ) = ( * )
! ( -x21 ) = ( 0 )
! ( scale ) = ( 0 )
u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = scale
call stdlib${ii}$_slarfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau )
u( 1_${ik}$ ) = one
t33 = t( j3, j3 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_slarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_slarfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work )
t( j1, j1 ) = t33
t( j2, j1 ) = zero
t( j3, j1 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
30 continue
! n1 = 2, n2 = 2: generate elementary reflectors h(1) and h(2) so
! that:
! h(2) h(1) ( -x11 -x12 ) = ( * * )
! ( -x21 -x22 ) ( 0 * )
! ( scale 0 ) ( 0 0 )
! ( 0 scale ) ( 0 0 )
u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u1( 3_${ik}$ ) = scale
call stdlib${ii}$_slarfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 )
u1( 1_${ik}$ ) = one
temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) )
u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ )
u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ )
u2( 3_${ik}$ ) = scale
call stdlib${ii}$_slarfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 )
u2( 1_${ik}$ ) = one
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_slarfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work )
call stdlib${ii}$_slarfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work )
! test whether to reject swap.
if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )&
>thresh )go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
call stdlib${ii}$_slarfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
call stdlib${ii}$_slarfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j4, j1 ) = zero
t( j4, j2 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work )
call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work )
end if
40 continue
if( n2==2_${ik}$ ) then
! standardize new 2-by-2 block t11
call stdlib${ii}$_slanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, &
wr2, wi2, cs, sn )
call stdlib${ii}$_srot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn )
call stdlib${ii}$_srot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_srot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
if( n1==2_${ik}$ ) then
! standardize new 2-by-2 block t22
j3 = j1 + n2
j4 = j3 + 1_${ik}$
call stdlib${ii}$_slanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, &
wr2, wi2, cs, sn )
if( j3+2<=n )call stdlib${ii}$_srot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,&
sn )
call stdlib${ii}$_srot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_srot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
end if
end if
return
! exit with info = 1 if swap was rejected.
50 continue
info = 1_${ik}$
return
end subroutine stdlib${ii}$_slaexc
module subroutine stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info )
!! DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
!! an upper quasi-triangular matrix T by an orthogonal similarity
!! transformation.
!! T must be in Schur canonical form, that is, block upper triangular
!! with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
!! has its diagonal elements equal and its off-diagonal elements of
!! opposite sign.
! -- 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
logical(lk), intent(in) :: wantq
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: j1, ldq, ldt, n, n1, n2
! Array Arguments
real(dp), intent(inout) :: q(ldq,*), t(ldt,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ldd = 4_${ik}$
integer(${ik}$), parameter :: ldx = 2_${ik}$
! Local Scalars
integer(${ik}$) :: ierr, j2, j3, j4, k, nd
real(dp) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, &
thresh, wi1, wi2, wr1, wr2, xnorm
! Local Arrays
real(dp) :: d(ldd,4_${ik}$), u(3_${ik}$), u1(3_${ik}$), u2(3_${ik}$), x(ldx,2_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 .or. n1==0 .or. n2==0 )return
if( j1+n1>n )return
j2 = j1 + 1_${ik}$
j3 = j1 + 2_${ik}$
j4 = j1 + 3_${ik}$
if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then
! swap two 1-by-1 blocks.
t11 = t( j1, j1 )
t22 = t( j2, j2 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_dlartg( t( j1, j2 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( j3<=n )call stdlib${ii}$_drot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn )
call stdlib${ii}$_drot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
t( j1, j1 ) = t22
t( j2, j2 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_drot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
else
! swapping involves at least one 2-by-2 block.
! copy the diagonal block of order n1+n2 to the local array d
! and compute its norm.
nd = n1 + n2
call stdlib${ii}$_dlacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd )
dnorm = stdlib${ii}$_dlange( 'MAX', nd, nd, d, ldd, work )
! compute machine-dependent threshold for test for accepting
! swap.
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' ) / eps
thresh = max( ten*eps*dnorm, smlnum )
! solve t11*x - x*t22 = scale*t12 for x.
call stdlib${ii}$_dlasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,&
n1+1 ), ldd, scale, x,ldx, xnorm, ierr )
! swap the adjacent diagonal blocks.
k = n1 + n1 + n2 - 3_${ik}$
go to ( 10, 20, 30 )k
10 continue
! n1 = 1, n2 = 2: generate elementary reflector h so that:
! ( scale, x11, x12 ) h = ( 0, 0, * )
u( 1_${ik}$ ) = scale
u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )
call stdlib${ii}$_dlarfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau )
u( 3_${ik}$ ) = one
t11 = t( j1, j1 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_dlarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh ) go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
call stdlib${ii}$_dlarfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j3, j3 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
20 continue
! n1 = 2, n2 = 1: generate elementary reflector h so that:
! h ( -x11 ) = ( * )
! ( -x21 ) = ( 0 )
! ( scale ) = ( 0 )
u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = scale
call stdlib${ii}$_dlarfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau )
u( 1_${ik}$ ) = one
t33 = t( j3, j3 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_dlarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh ) go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_dlarfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work )
t( j1, j1 ) = t33
t( j2, j1 ) = zero
t( j3, j1 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
30 continue
! n1 = 2, n2 = 2: generate elementary reflectors h(1) and h(2) so
! that:
! h(2) h(1) ( -x11 -x12 ) = ( * * )
! ( -x21 -x22 ) ( 0 * )
! ( scale 0 ) ( 0 0 )
! ( 0 scale ) ( 0 0 )
u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u1( 3_${ik}$ ) = scale
call stdlib${ii}$_dlarfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 )
u1( 1_${ik}$ ) = one
temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) )
u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ )
u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ )
u2( 3_${ik}$ ) = scale
call stdlib${ii}$_dlarfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 )
u2( 1_${ik}$ ) = one
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_dlarfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work )
call stdlib${ii}$_dlarfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work )
! test whether to reject swap.
if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )&
>thresh )go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
call stdlib${ii}$_dlarfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
call stdlib${ii}$_dlarfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j4, j1 ) = zero
t( j4, j2 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work )
call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work )
end if
40 continue
if( n2==2_${ik}$ ) then
! standardize new 2-by-2 block t11
call stdlib${ii}$_dlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, &
wr2, wi2, cs, sn )
call stdlib${ii}$_drot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn )
call stdlib${ii}$_drot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_drot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
if( n1==2_${ik}$ ) then
! standardize new 2-by-2 block t22
j3 = j1 + n2
j4 = j3 + 1_${ik}$
call stdlib${ii}$_dlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, &
wr2, wi2, cs, sn )
if( j3+2<=n )call stdlib${ii}$_drot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,&
sn )
call stdlib${ii}$_drot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_drot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
end if
end if
return
! exit with info = 1 if swap was rejected.
50 continue
info = 1_${ik}$
return
end subroutine stdlib${ii}$_dlaexc
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info )
!! DLAEXC: swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
!! an upper quasi-triangular matrix T by an orthogonal similarity
!! transformation.
!! T must be in Schur canonical form, that is, block upper triangular
!! with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
!! has its diagonal elements equal and its off-diagonal elements of
!! opposite sign.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: wantq
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: j1, ldq, ldt, n, n1, n2
! Array Arguments
real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: ldd = 4_${ik}$
integer(${ik}$), parameter :: ldx = 2_${ik}$
! Local Scalars
integer(${ik}$) :: ierr, j2, j3, j4, k, nd
real(${rk}$) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, &
thresh, wi1, wi2, wr1, wr2, xnorm
! Local Arrays
real(${rk}$) :: d(ldd,4_${ik}$), u(3_${ik}$), u1(3_${ik}$), u2(3_${ik}$), x(ldx,2_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! quick return if possible
if( n==0 .or. n1==0 .or. n2==0 )return
if( j1+n1>n )return
j2 = j1 + 1_${ik}$
j3 = j1 + 2_${ik}$
j4 = j1 + 3_${ik}$
if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then
! swap two 1-by-1 blocks.
t11 = t( j1, j1 )
t22 = t( j2, j2 )
! determine the transformation to perform the interchange.
call stdlib${ii}$_${ri}$lartg( t( j1, j2 ), t22-t11, cs, sn, temp )
! apply transformation to the matrix t.
if( j3<=n )call stdlib${ii}$_${ri}$rot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn )
call stdlib${ii}$_${ri}$rot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
t( j1, j1 ) = t22
t( j2, j2 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
else
! swapping involves at least one 2-by-2 block.
! copy the diagonal block of order n1+n2 to the local array d
! and compute its norm.
nd = n1 + n2
call stdlib${ii}$_${ri}$lacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd )
dnorm = stdlib${ii}$_${ri}$lange( 'MAX', nd, nd, d, ldd, work )
! compute machine-dependent threshold for test for accepting
! swap.
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps
thresh = max( ten*eps*dnorm, smlnum )
! solve t11*x - x*t22 = scale*t12 for x.
call stdlib${ii}$_${ri}$lasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,&
n1+1 ), ldd, scale, x,ldx, xnorm, ierr )
! swap the adjacent diagonal blocks.
k = n1 + n1 + n2 - 3_${ik}$
go to ( 10, 20, 30 )k
10 continue
! n1 = 1, n2 = 2: generate elementary reflector h so that:
! ( scale, x11, x12 ) h = ( 0, 0, * )
u( 1_${ik}$ ) = scale
u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )
call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau )
u( 3_${ik}$ ) = one
t11 = t( j1, j1 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_${ri}$larfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh ) goto 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
call stdlib${ii}$_${ri}$larfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j3, j3 ) = t11
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
20 continue
! n1 = 2, n2 = 1: generate elementary reflector h so that:
! h ( -x11 ) = ( * )
! ( -x21 ) = ( 0 )
! ( scale ) = ( 0 )
u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u( 3_${ik}$ ) = scale
call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau )
u( 1_${ik}$ ) = one
t33 = t( j3, j3 )
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
call stdlib${ii}$_${ri}$larfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work )
! test whether to reject swap.
if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh ) goto 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_${ri}$larfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work )
t( j1, j1 ) = t33
t( j2, j1 ) = zero
t( j3, j1 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work )
end if
go to 40
30 continue
! n1 = 2, n2 = 2: generate elementary reflectors h(1) and h(2) so
! that:
! h(2) h(1) ( -x11 -x12 ) = ( * * )
! ( -x21 -x22 ) ( 0 * )
! ( scale 0 ) ( 0 0 )
! ( 0 scale ) ( 0 0 )
u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ )
u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ )
u1( 3_${ik}$ ) = scale
call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 )
u1( 1_${ik}$ ) = one
temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) )
u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ )
u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ )
u2( 3_${ik}$ ) = scale
call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 )
u2( 1_${ik}$ ) = one
! perform swap provisionally on diagonal block in d.
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_${ri}$larfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work )
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work )
call stdlib${ii}$_${ri}$larfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work )
! test whether to reject swap.
if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )&
>thresh )go to 50
! accept swap: apply transformation to the entire matrix t.
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
call stdlib${ii}$_${ri}$larfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work )
call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
call stdlib${ii}$_${ri}$larfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work )
t( j3, j1 ) = zero
t( j3, j2 ) = zero
t( j4, j1 ) = zero
t( j4, j2 ) = zero
if( wantq ) then
! accumulate transformation in the matrix q.
call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work )
call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work )
end if
40 continue
if( n2==2_${ik}$ ) then
! standardize new 2-by-2 block t11
call stdlib${ii}$_${ri}$lanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, &
wr2, wi2, cs, sn )
call stdlib${ii}$_${ri}$rot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn )
call stdlib${ii}$_${ri}$rot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn )
end if
if( n1==2_${ik}$ ) then
! standardize new 2-by-2 block t22
j3 = j1 + n2
j4 = j3 + 1_${ik}$
call stdlib${ii}$_${ri}$lanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, &
wr2, wi2, cs, sn )
if( j3+2<=n )call stdlib${ii}$_${ri}$rot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,&
sn )
call stdlib${ii}$_${ri}$rot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
if( wantq )call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn )
end if
end if
return
! exit with info = 1 if swap was rejected.
50 continue
info = 1_${ik}$
return
end subroutine stdlib${ii}$_${ri}$laexc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn )
!! SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
!! matrix in standard form:
!! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
!! [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
!! where either
!! 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!! 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!! conjugate eigenvalues.
! -- 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
real(sp), intent(inout) :: a, b, c, d
real(sp), intent(out) :: cs, rt1i, rt1r, rt2i, rt2r, sn
! =====================================================================
! Parameters
real(sp), parameter :: multpl = 4.0e+0_sp
! Local Scalars
real(sp) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, &
tau, temp, z, safmin, safmn2, safmx2
integer(${ik}$) :: count
! Intrinsic Functions
! Executable Statements
safmin = stdlib${ii}$_slamch( 'S' )
eps = stdlib${ii}$_slamch( 'P' )
safmn2 = stdlib${ii}$_slamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_slamch( 'B' ) ) / &
two,KIND=${ik}$)
safmx2 = one / safmn2
if( c==zero ) then
cs = one
sn = zero
else if( b==zero ) then
! swap rows and columns
cs = zero
sn = one
temp = d
d = a
a = temp
b = -c
c = zero
else if( (a-d)==zero .and. sign( one, b )/=sign( one, c ) ) then
cs = one
sn = zero
else
temp = a - d
p = half*temp
bcmax = max( abs( b ), abs( c ) )
bcmis = min( abs( b ), abs( c ) )*sign( one, b )*sign( one, c )
scale = max( abs( p ), bcmax )
z = ( p / scale )*p + ( bcmax / scale )*bcmis
! if z is of the order of the machine accuracy, postpone the
! decision on the nature of eigenvalues
if( z>=multpl*eps ) then
! real eigenvalues. compute a and d.
z = p + sign( sqrt( scale )*sqrt( z ), p )
a = d + z
d = d - ( bcmax / z )*bcmis
! compute b and the rotation matrix
tau = stdlib${ii}$_slapy2( c, z )
cs = z / tau
sn = c / tau
b = b - c
c = zero
else
! complex eigenvalues, or real(almost,KIND=sp) equal eigenvalues.
! make diagonal elements equal.
count = 0_${ik}$
sigma = b + c
10 continue
count = count + 1_${ik}$
scale = max( abs(temp), abs(sigma) )
if( scale>=safmx2 ) then
sigma = sigma * safmn2
temp = temp * safmn2
if (count <= 20)goto 10
end if
if( scale<=safmn2 ) then
sigma = sigma * safmx2
temp = temp * safmx2
if (count <= 20)goto 10
end if
p = half*temp
tau = stdlib${ii}$_slapy2( sigma, temp )
cs = sqrt( half*( one+abs( sigma ) / tau ) )
sn = -( p / ( tau*cs ) )*sign( one, sigma )
! compute [ aa bb ] = [ a b ] [ cs -sn ]
! [ cc dd ] [ c d ] [ sn cs ]
aa = a*cs + b*sn
bb = -a*sn + b*cs
cc = c*cs + d*sn
dd = -c*sn + d*cs
! compute [ a b ] = [ cs sn ] [ aa bb ]
! [ c d ] [-sn cs ] [ cc dd ]
a = aa*cs + cc*sn
b = bb*cs + dd*sn
c = -aa*sn + cc*cs
d = -bb*sn + dd*cs
temp = half*( a+d )
a = temp
d = temp
if( c/=zero ) then
if( b/=zero ) then
if( sign( one, b )==sign( one, c ) ) then
! real eigenvalues: reduce to upper triangular form
sab = sqrt( abs( b ) )
sac = sqrt( abs( c ) )
p = sign( sab*sac, c )
tau = one / sqrt( abs( b+c ) )
a = temp + p
d = temp - p
b = b - c
c = zero
cs1 = sab*tau
sn1 = sac*tau
temp = cs*cs1 - sn*sn1
sn = cs*sn1 + sn*cs1
cs = temp
end if
else
b = -c
c = zero
temp = cs
cs = -sn
sn = temp
end if
end if
end if
end if
! store eigenvalues in (rt1r,rt1i) and (rt2r,rt2i).
rt1r = a
rt2r = d
if( c==zero ) then
rt1i = zero
rt2i = zero
else
rt1i = sqrt( abs( b ) )*sqrt( abs( c ) )
rt2i = -rt1i
end if
return
end subroutine stdlib${ii}$_slanv2
pure module subroutine stdlib${ii}$_dlanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn )
!! DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
!! matrix in standard form:
!! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
!! [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
!! where either
!! 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!! 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!! conjugate eigenvalues.
! -- 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
real(dp), intent(inout) :: a, b, c, d
real(dp), intent(out) :: cs, rt1i, rt1r, rt2i, rt2r, sn
! =====================================================================
! Parameters
real(dp), parameter :: multpl = 4.0e+0_dp
! Local Scalars
real(dp) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, &
tau, temp, z, safmin, safmn2, safmx2
integer(${ik}$) :: count
! Intrinsic Functions
! Executable Statements
safmin = stdlib${ii}$_dlamch( 'S' )
eps = stdlib${ii}$_dlamch( 'P' )
safmn2 = stdlib${ii}$_dlamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_dlamch( 'B' ) ) / &
two,KIND=${ik}$)
safmx2 = one / safmn2
if( c==zero ) then
cs = one
sn = zero
else if( b==zero ) then
! swap rows and columns
cs = zero
sn = one
temp = d
d = a
a = temp
b = -c
c = zero
else if( ( a-d )==zero .and. sign( one, b )/=sign( one, c ) )then
cs = one
sn = zero
else
temp = a - d
p = half*temp
bcmax = max( abs( b ), abs( c ) )
bcmis = min( abs( b ), abs( c ) )*sign( one, b )*sign( one, c )
scale = max( abs( p ), bcmax )
z = ( p / scale )*p + ( bcmax / scale )*bcmis
! if z is of the order of the machine accuracy, postpone the
! decision on the nature of eigenvalues
if( z>=multpl*eps ) then
! real eigenvalues. compute a and d.
z = p + sign( sqrt( scale )*sqrt( z ), p )
a = d + z
d = d - ( bcmax / z )*bcmis
! compute b and the rotation matrix
tau = stdlib${ii}$_dlapy2( c, z )
cs = z / tau
sn = c / tau
b = b - c
c = zero
else
! complex eigenvalues, or real(almost,KIND=dp) equal eigenvalues.
! make diagonal elements equal.
count = 0_${ik}$
sigma = b + c
10 continue
count = count + 1_${ik}$
scale = max( abs(temp), abs(sigma) )
if( scale>=safmx2 ) then
sigma = sigma * safmn2
temp = temp * safmn2
if (count <= 20)goto 10
end if
if( scale<=safmn2 ) then
sigma = sigma * safmx2
temp = temp * safmx2
if (count <= 20)goto 10
end if
p = half*temp
tau = stdlib${ii}$_dlapy2( sigma, temp )
cs = sqrt( half*( one+abs( sigma ) / tau ) )
sn = -( p / ( tau*cs ) )*sign( one, sigma )
! compute [ aa bb ] = [ a b ] [ cs -sn ]
! [ cc dd ] [ c d ] [ sn cs ]
aa = a*cs + b*sn
bb = -a*sn + b*cs
cc = c*cs + d*sn
dd = -c*sn + d*cs
! compute [ a b ] = [ cs sn ] [ aa bb ]
! [ c d ] [-sn cs ] [ cc dd ]
a = aa*cs + cc*sn
b = bb*cs + dd*sn
c = -aa*sn + cc*cs
d = -bb*sn + dd*cs
temp = half*( a+d )
a = temp
d = temp
if( c/=zero ) then
if( b/=zero ) then
if( sign( one, b )==sign( one, c ) ) then
! real eigenvalues: reduce to upper triangular form
sab = sqrt( abs( b ) )
sac = sqrt( abs( c ) )
p = sign( sab*sac, c )
tau = one / sqrt( abs( b+c ) )
a = temp + p
d = temp - p
b = b - c
c = zero
cs1 = sab*tau
sn1 = sac*tau
temp = cs*cs1 - sn*sn1
sn = cs*sn1 + sn*cs1
cs = temp
end if
else
b = -c
c = zero
temp = cs
cs = -sn
sn = temp
end if
end if
end if
end if
! store eigenvalues in (rt1r,rt1i) and (rt2r,rt2i).
rt1r = a
rt2r = d
if( c==zero ) then
rt1i = zero
rt2i = zero
else
rt1i = sqrt( abs( b ) )*sqrt( abs( c ) )
rt2i = -rt1i
end if
return
end subroutine stdlib${ii}$_dlanv2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn )
!! DLANV2: computes the Schur factorization of a real 2-by-2 nonsymmetric
!! matrix in standard form:
!! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
!! [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
!! where either
!! 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!! 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!! conjugate eigenvalues.
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
real(${rk}$), intent(inout) :: a, b, c, d
real(${rk}$), intent(out) :: cs, rt1i, rt1r, rt2i, rt2r, sn
! =====================================================================
! Parameters
real(${rk}$), parameter :: multpl = 4.0e+0_${rk}$
! Local Scalars
real(${rk}$) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, &
tau, temp, z, safmin, safmn2, safmx2
integer(${ik}$) :: count
! Intrinsic Functions
! Executable Statements
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
eps = stdlib${ii}$_${ri}$lamch( 'P' )
safmn2 = stdlib${ii}$_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_${ri}$lamch( 'B' ) ) / &
two,KIND=${ik}$)
safmx2 = one / safmn2
if( c==zero ) then
cs = one
sn = zero
else if( b==zero ) then
! swap rows and columns
cs = zero
sn = one
temp = d
d = a
a = temp
b = -c
c = zero
else if( ( a-d )==zero .and. sign( one, b )/=sign( one, c ) )then
cs = one
sn = zero
else
temp = a - d
p = half*temp
bcmax = max( abs( b ), abs( c ) )
bcmis = min( abs( b ), abs( c ) )*sign( one, b )*sign( one, c )
scale = max( abs( p ), bcmax )
z = ( p / scale )*p + ( bcmax / scale )*bcmis
! if z is of the order of the machine accuracy, postpone the
! decision on the nature of eigenvalues
if( z>=multpl*eps ) then
! real eigenvalues. compute a and d.
z = p + sign( sqrt( scale )*sqrt( z ), p )
a = d + z
d = d - ( bcmax / z )*bcmis
! compute b and the rotation matrix
tau = stdlib${ii}$_${ri}$lapy2( c, z )
cs = z / tau
sn = c / tau
b = b - c
c = zero
else
! complex eigenvalues, or real(almost,KIND=${rk}$) equal eigenvalues.
! make diagonal elements equal.
count = 0_${ik}$
sigma = b + c
10 continue
count = count + 1_${ik}$
scale = max( abs(temp), abs(sigma) )
if( scale>=safmx2 ) then
sigma = sigma * safmn2
temp = temp * safmn2
if (count <= 20)goto 10
end if
if( scale<=safmn2 ) then
sigma = sigma * safmx2
temp = temp * safmx2
if (count <= 20)goto 10
end if
p = half*temp
tau = stdlib${ii}$_${ri}$lapy2( sigma, temp )
cs = sqrt( half*( one+abs( sigma ) / tau ) )
sn = -( p / ( tau*cs ) )*sign( one, sigma )
! compute [ aa bb ] = [ a b ] [ cs -sn ]
! [ cc dd ] [ c d ] [ sn cs ]
aa = a*cs + b*sn
bb = -a*sn + b*cs
cc = c*cs + d*sn
dd = -c*sn + d*cs
! compute [ a b ] = [ cs sn ] [ aa bb ]
! [ c d ] [-sn cs ] [ cc dd ]
a = aa*cs + cc*sn
b = bb*cs + dd*sn
c = -aa*sn + cc*cs
d = -bb*sn + dd*cs
temp = half*( a+d )
a = temp
d = temp
if( c/=zero ) then
if( b/=zero ) then
if( sign( one, b )==sign( one, c ) ) then
! real eigenvalues: reduce to upper triangular form
sab = sqrt( abs( b ) )
sac = sqrt( abs( c ) )
p = sign( sab*sac, c )
tau = one / sqrt( abs( b+c ) )
a = temp + p
d = temp - p
b = b - c
c = zero
cs1 = sab*tau
sn1 = sac*tau
temp = cs*cs1 - sn*sn1
sn = cs*sn1 + sn*cs1
cs = temp
end if
else
b = -c
c = zero
temp = cs
cs = -sn
sn = temp
end if
end if
end if
end if
! store eigenvalues in (rt1r,rt1i) and (rt2r,rt2i).
rt1r = a
rt2r = d
if( c==zero ) then
rt1i = zero
rt2i = zero
else
rt1i = sqrt( abs( b ) )*sqrt( abs( c ) )
rt2i = -rt1i
end if
return
end subroutine stdlib${ii}$_${ri}$lanv2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, &
!! SLAEIN uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!! matrix H.
smlnum, bignum, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(sp), intent(in) :: bignum, eps3, smlnum, wi, wr
! Array Arguments
real(sp), intent(out) :: b(ldb,*), work(*)
real(sp), intent(in) :: h(ldh,*)
real(sp), intent(inout) :: vi(*), vr(*)
! =====================================================================
! Parameters
real(sp), parameter :: tenth = 1.0e-1_sp
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, i1, i2, i3, ierr, its, j
real(sp) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, &
vcrit, vmax, vnorm, w, w1, x, xi, xr, y
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=sp) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - (wr,wi)*i (except that the subdiagonal elements and
! the imaginary parts of the diagonal elements are not stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - wr
end do
if( wi==zero ) then
! real eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_snrm2( n, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( abs( b( i, i ) )<abs( ei ) ) then
! interchange rows and eliminate.
x = b( i, i ) / ei
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==zero )b( i, i ) = eps3
x = ei / b( i, i )
if( x/=zero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==zero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( abs( b( j, j ) )<abs( ej ) ) then
! interchange columns and eliminate.
x = b( j, j ) / ej
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==zero )b( j, j ) = eps3
x = ej / b( j, j )
if( x/=zero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'T'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**t*x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_slatrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,&
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_sasum( n, vr, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
temp = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
do i = 2, n
vr( i ) = temp
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_isamax( n, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, one / abs( vr( i ) ), vr, 1_${ik}$ )
else
! complex eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
vi( i ) = zero
end do
else
! scale supplied initial vector.
norm = stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_snrm2( n, vi, 1_${ik}$ ) )
rec = ( eps3*rootn ) / max( norm, nrmsml )
call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( 2_${ik}$, 1_${ik}$ ) = -wi
do i = 2, n
b( i+1, 1_${ik}$ ) = zero
end do
loop_170: do i = 1, n - 1
absbii = stdlib${ii}$_slapy2( b( i, i ), b( i+1, i ) )
ei = h( i+1, i )
if( absbii<abs( ei ) ) then
! interchange rows and eliminate.
xr = b( i, i ) / ei
xi = b( i+1, i ) / ei
b( i, i ) = ei
b( i+1, i ) = zero
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - xr*temp
b( j+1, i+1 ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( i+2, i ) = -wi
b( i+1, i+1 ) = b( i+1, i+1 ) - xi*wi
b( i+2, i+1 ) = b( i+2, i+1 ) + xr*wi
else
! eliminate without interchanging rows.
if( absbii==zero ) then
b( i, i ) = eps3
b( i+1, i ) = zero
absbii = eps3
end if
ei = ( ei / absbii ) / absbii
xr = b( i, i )*ei
xi = -b( i+1, i )*ei
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - xr*b( i, j ) +xi*b( j+1, i )
b( j+1, i+1 ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( i+2, i+1 ) = b( i+2, i+1 ) - wi
end if
! compute 1-norm of offdiagonal elements of i-th row.
work( i ) = stdlib${ii}$_sasum( n-i, b( i, i+1 ), ldb ) +stdlib${ii}$_sasum( n-i, b( i+2, &
i ), 1_${ik}$ )
end do loop_170
if( b( n, n )==zero .and. b( n+1, n )==zero )b( n, n ) = eps3
work( n ) = zero
i1 = n
i2 = 1_${ik}$
i3 = -1_${ik}$
else
! ul decomposition with partial pivoting of conjg(b),
! replacing zero pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( n+1, n ) = wi
do j = 1, n - 1
b( n+1, j ) = zero
end do
loop_210: do j = n, 2, -1
ej = h( j, j-1 )
absbjj = stdlib${ii}$_slapy2( b( j, j ), b( j+1, j ) )
if( absbjj<abs( ej ) ) then
! interchange columns and eliminate
xr = b( j, j ) / ej
xi = b( j+1, j ) / ej
b( j, j ) = ej
b( j+1, j ) = zero
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - xr*temp
b( j, i ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( j+1, j-1 ) = wi
b( j-1, j-1 ) = b( j-1, j-1 ) + xi*wi
b( j, j-1 ) = b( j, j-1 ) - xr*wi
else
! eliminate without interchange.
if( absbjj==zero ) then
b( j, j ) = eps3
b( j+1, j ) = zero
absbjj = eps3
end if
ej = ( ej / absbjj ) / absbjj
xr = b( j, j )*ej
xi = -b( j+1, j )*ej
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - xr*b( i, j ) +xi*b( j+1, i )
b( j, i ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( j, j-1 ) = b( j, j-1 ) + wi
end if
! compute 1-norm of offdiagonal elements of j-th column.
work( j ) = stdlib${ii}$_sasum( j-1, b( 1_${ik}$, j ), 1_${ik}$ ) +stdlib${ii}$_sasum( j-1, b( j+1, 1_${ik}$ ),&
ldb )
end do loop_210
if( b( 1_${ik}$, 1_${ik}$ )==zero .and. b( 2_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
work( 1_${ik}$ ) = zero
i1 = 1_${ik}$
i2 = n
i3 = 1_${ik}$
end if
loop_270: do its = 1, n
scale = one
vmax = one
vcrit = bignum
! solve u*(xr,xi) = scale*(vr,vi) for a right eigenvector,
! or u**t*(xr,xi) = scale*(vr,vi) for a left eigenvector,
! overwriting (xr,xi) on (vr,vi).
loop_250: do i = i1, i2, i3
if( work( i )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ )
scale = scale*rec
vmax = one
vcrit = bignum
end if
xr = vr( i )
xi = vi( i )
if( rightv ) then
do j = i + 1, n
xr = xr - b( i, j )*vr( j ) + b( j+1, i )*vi( j )
xi = xi - b( i, j )*vi( j ) - b( j+1, i )*vr( j )
end do
else
do j = 1, i - 1
xr = xr - b( j, i )*vr( j ) + b( i+1, j )*vi( j )
xi = xi - b( j, i )*vi( j ) - b( i+1, j )*vr( j )
end do
end if
w = abs( b( i, i ) ) + abs( b( i+1, i ) )
if( w>smlnum ) then
if( w<one ) then
w1 = abs( xr ) + abs( xi )
if( w1>w*bignum ) then
rec = one / w1
call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ )
xr = vr( i )
xi = vi( i )
scale = scale*rec
vmax = vmax*rec
end if
end if
! divide by diagonal element of b.
call stdlib${ii}$_sladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) )
vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax )
vcrit = bignum / vmax
else
do j = 1, n
vr( j ) = zero
vi( j ) = zero
end do
vr( i ) = one
vi( i ) = one
scale = zero
vmax = one
vcrit = bignum
end if
end do loop_250
! test for sufficient growth in the norm of (vr,vi).
vnorm = stdlib${ii}$_sasum( n, vr, 1_${ik}$ ) + stdlib${ii}$_sasum( n, vi, 1_${ik}$ )
if( vnorm>=growto*scale )go to 280
! choose a new orthogonal starting vector and try again.
y = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
vi( 1_${ik}$ ) = zero
do i = 2, n
vr( i ) = y
vi( i ) = zero
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do loop_270
! failure to find eigenvector in n iterations
info = 1_${ik}$
280 continue
! normalize eigenvector.
vnorm = zero
do i = 1, n
vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) )
end do
call stdlib${ii}$_sscal( n, one / vnorm, vr, 1_${ik}$ )
call stdlib${ii}$_sscal( n, one / vnorm, vi, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_slaein
pure module subroutine stdlib${ii}$_dlaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, &
!! DLAEIN uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!! matrix H.
smlnum, bignum, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(dp), intent(in) :: bignum, eps3, smlnum, wi, wr
! Array Arguments
real(dp), intent(out) :: b(ldb,*), work(*)
real(dp), intent(in) :: h(ldh,*)
real(dp), intent(inout) :: vi(*), vr(*)
! =====================================================================
! Parameters
real(dp), parameter :: tenth = 1.0e-1_dp
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, i1, i2, i3, ierr, its, j
real(dp) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, &
vcrit, vmax, vnorm, w, w1, x, xi, xr, y
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=dp) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - (wr,wi)*i (except that the subdiagonal elements and
! the imaginary parts of the diagonal elements are not stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - wr
end do
if( wi==zero ) then
! real eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_dnrm2( n, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( abs( b( i, i ) )<abs( ei ) ) then
! interchange rows and eliminate.
x = b( i, i ) / ei
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==zero )b( i, i ) = eps3
x = ei / b( i, i )
if( x/=zero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==zero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( abs( b( j, j ) )<abs( ej ) ) then
! interchange columns and eliminate.
x = b( j, j ) / ej
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==zero )b( j, j ) = eps3
x = ej / b( j, j )
if( x/=zero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'T'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**t*x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_dlatrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,&
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_dasum( n, vr, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
temp = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
do i = 2, n
vr( i ) = temp
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_idamax( n, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, one / abs( vr( i ) ), vr, 1_${ik}$ )
else
! complex eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
vi( i ) = zero
end do
else
! scale supplied initial vector.
norm = stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_dnrm2( n, vi, 1_${ik}$ ) )
rec = ( eps3*rootn ) / max( norm, nrmsml )
call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( 2_${ik}$, 1_${ik}$ ) = -wi
do i = 2, n
b( i+1, 1_${ik}$ ) = zero
end do
loop_170: do i = 1, n - 1
absbii = stdlib${ii}$_dlapy2( b( i, i ), b( i+1, i ) )
ei = h( i+1, i )
if( absbii<abs( ei ) ) then
! interchange rows and eliminate.
xr = b( i, i ) / ei
xi = b( i+1, i ) / ei
b( i, i ) = ei
b( i+1, i ) = zero
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - xr*temp
b( j+1, i+1 ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( i+2, i ) = -wi
b( i+1, i+1 ) = b( i+1, i+1 ) - xi*wi
b( i+2, i+1 ) = b( i+2, i+1 ) + xr*wi
else
! eliminate without interchanging rows.
if( absbii==zero ) then
b( i, i ) = eps3
b( i+1, i ) = zero
absbii = eps3
end if
ei = ( ei / absbii ) / absbii
xr = b( i, i )*ei
xi = -b( i+1, i )*ei
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - xr*b( i, j ) +xi*b( j+1, i )
b( j+1, i+1 ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( i+2, i+1 ) = b( i+2, i+1 ) - wi
end if
! compute 1-norm of offdiagonal elements of i-th row.
work( i ) = stdlib${ii}$_dasum( n-i, b( i, i+1 ), ldb ) +stdlib${ii}$_dasum( n-i, b( i+2, &
i ), 1_${ik}$ )
end do loop_170
if( b( n, n )==zero .and. b( n+1, n )==zero )b( n, n ) = eps3
work( n ) = zero
i1 = n
i2 = 1_${ik}$
i3 = -1_${ik}$
else
! ul decomposition with partial pivoting of conjg(b),
! replacing zero pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( n+1, n ) = wi
do j = 1, n - 1
b( n+1, j ) = zero
end do
loop_210: do j = n, 2, -1
ej = h( j, j-1 )
absbjj = stdlib${ii}$_dlapy2( b( j, j ), b( j+1, j ) )
if( absbjj<abs( ej ) ) then
! interchange columns and eliminate
xr = b( j, j ) / ej
xi = b( j+1, j ) / ej
b( j, j ) = ej
b( j+1, j ) = zero
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - xr*temp
b( j, i ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( j+1, j-1 ) = wi
b( j-1, j-1 ) = b( j-1, j-1 ) + xi*wi
b( j, j-1 ) = b( j, j-1 ) - xr*wi
else
! eliminate without interchange.
if( absbjj==zero ) then
b( j, j ) = eps3
b( j+1, j ) = zero
absbjj = eps3
end if
ej = ( ej / absbjj ) / absbjj
xr = b( j, j )*ej
xi = -b( j+1, j )*ej
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - xr*b( i, j ) +xi*b( j+1, i )
b( j, i ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( j, j-1 ) = b( j, j-1 ) + wi
end if
! compute 1-norm of offdiagonal elements of j-th column.
work( j ) = stdlib${ii}$_dasum( j-1, b( 1_${ik}$, j ), 1_${ik}$ ) +stdlib${ii}$_dasum( j-1, b( j+1, 1_${ik}$ ),&
ldb )
end do loop_210
if( b( 1_${ik}$, 1_${ik}$ )==zero .and. b( 2_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
work( 1_${ik}$ ) = zero
i1 = 1_${ik}$
i2 = n
i3 = 1_${ik}$
end if
loop_270: do its = 1, n
scale = one
vmax = one
vcrit = bignum
! solve u*(xr,xi) = scale*(vr,vi) for a right eigenvector,
! or u**t*(xr,xi) = scale*(vr,vi) for a left eigenvector,
! overwriting (xr,xi) on (vr,vi).
loop_250: do i = i1, i2, i3
if( work( i )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ )
scale = scale*rec
vmax = one
vcrit = bignum
end if
xr = vr( i )
xi = vi( i )
if( rightv ) then
do j = i + 1, n
xr = xr - b( i, j )*vr( j ) + b( j+1, i )*vi( j )
xi = xi - b( i, j )*vi( j ) - b( j+1, i )*vr( j )
end do
else
do j = 1, i - 1
xr = xr - b( j, i )*vr( j ) + b( i+1, j )*vi( j )
xi = xi - b( j, i )*vi( j ) - b( i+1, j )*vr( j )
end do
end if
w = abs( b( i, i ) ) + abs( b( i+1, i ) )
if( w>smlnum ) then
if( w<one ) then
w1 = abs( xr ) + abs( xi )
if( w1>w*bignum ) then
rec = one / w1
call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ )
xr = vr( i )
xi = vi( i )
scale = scale*rec
vmax = vmax*rec
end if
end if
! divide by diagonal element of b.
call stdlib${ii}$_dladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) )
vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax )
vcrit = bignum / vmax
else
do j = 1, n
vr( j ) = zero
vi( j ) = zero
end do
vr( i ) = one
vi( i ) = one
scale = zero
vmax = one
vcrit = bignum
end if
end do loop_250
! test for sufficient growth in the norm of (vr,vi).
vnorm = stdlib${ii}$_dasum( n, vr, 1_${ik}$ ) + stdlib${ii}$_dasum( n, vi, 1_${ik}$ )
if( vnorm>=growto*scale )go to 280
! choose a new orthogonal starting vector and try again.
y = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
vi( 1_${ik}$ ) = zero
do i = 2, n
vr( i ) = y
vi( i ) = zero
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do loop_270
! failure to find eigenvector in n iterations
info = 1_${ik}$
280 continue
! normalize eigenvector.
vnorm = zero
do i = 1, n
vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) )
end do
call stdlib${ii}$_dscal( n, one / vnorm, vr, 1_${ik}$ )
call stdlib${ii}$_dscal( n, one / vnorm, vi, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dlaein
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, &
!! DLAEIN: uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!! matrix H.
smlnum, bignum, info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(${rk}$), intent(in) :: bignum, eps3, smlnum, wi, wr
! Array Arguments
real(${rk}$), intent(out) :: b(ldb,*), work(*)
real(${rk}$), intent(in) :: h(ldh,*)
real(${rk}$), intent(inout) :: vi(*), vr(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: tenth = 1.0e-1_${rk}$
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, i1, i2, i3, ierr, its, j
real(${rk}$) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, &
vcrit, vmax, vnorm, w, w1, x, xi, xr, y
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=${rk}$) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - (wr,wi)*i (except that the subdiagonal elements and
! the imaginary parts of the diagonal elements are not stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - wr
end do
if( wi==zero ) then
! real eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_${ri}$nrm2( n, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( abs( b( i, i ) )<abs( ei ) ) then
! interchange rows and eliminate.
x = b( i, i ) / ei
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==zero )b( i, i ) = eps3
x = ei / b( i, i )
if( x/=zero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==zero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( abs( b( j, j ) )<abs( ej ) ) then
! interchange columns and eliminate.
x = b( j, j ) / ej
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==zero )b( j, j ) = eps3
x = ej / b( j, j )
if( x/=zero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'T'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**t*x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_${ri}$latrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,&
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_${ri}$asum( n, vr, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
temp = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
do i = 2, n
vr( i ) = temp
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_i${ri}$amax( n, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, one / abs( vr( i ) ), vr, 1_${ik}$ )
else
! complex eigenvalue.
if( noinit ) then
! set initial vector.
do i = 1, n
vr( i ) = eps3
vi( i ) = zero
end do
else
! scale supplied initial vector.
norm = stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_${ri}$nrm2( n, vi, 1_${ik}$ ) )
rec = ( eps3*rootn ) / max( norm, nrmsml )
call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing zero
! pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( 2_${ik}$, 1_${ik}$ ) = -wi
do i = 2, n
b( i+1, 1_${ik}$ ) = zero
end do
loop_170: do i = 1, n - 1
absbii = stdlib${ii}$_${ri}$lapy2( b( i, i ), b( i+1, i ) )
ei = h( i+1, i )
if( absbii<abs( ei ) ) then
! interchange rows and eliminate.
xr = b( i, i ) / ei
xi = b( i+1, i ) / ei
b( i, i ) = ei
b( i+1, i ) = zero
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - xr*temp
b( j+1, i+1 ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( i+2, i ) = -wi
b( i+1, i+1 ) = b( i+1, i+1 ) - xi*wi
b( i+2, i+1 ) = b( i+2, i+1 ) + xr*wi
else
! eliminate without interchanging rows.
if( absbii==zero ) then
b( i, i ) = eps3
b( i+1, i ) = zero
absbii = eps3
end if
ei = ( ei / absbii ) / absbii
xr = b( i, i )*ei
xi = -b( i+1, i )*ei
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - xr*b( i, j ) +xi*b( j+1, i )
b( j+1, i+1 ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( i+2, i+1 ) = b( i+2, i+1 ) - wi
end if
! compute 1-norm of offdiagonal elements of i-th row.
work( i ) = stdlib${ii}$_${ri}$asum( n-i, b( i, i+1 ), ldb ) +stdlib${ii}$_${ri}$asum( n-i, b( i+2, &
i ), 1_${ik}$ )
end do loop_170
if( b( n, n )==zero .and. b( n+1, n )==zero )b( n, n ) = eps3
work( n ) = zero
i1 = n
i2 = 1_${ik}$
i3 = -1_${ik}$
else
! ul decomposition with partial pivoting of conjg(b),
! replacing zero pivots by eps3.
! the imaginary part of the (i,j)-th element of u is stored in
! b(j+1,i).
b( n+1, n ) = wi
do j = 1, n - 1
b( n+1, j ) = zero
end do
loop_210: do j = n, 2, -1
ej = h( j, j-1 )
absbjj = stdlib${ii}$_${ri}$lapy2( b( j, j ), b( j+1, j ) )
if( absbjj<abs( ej ) ) then
! interchange columns and eliminate
xr = b( j, j ) / ej
xi = b( j+1, j ) / ej
b( j, j ) = ej
b( j+1, j ) = zero
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - xr*temp
b( j, i ) = b( j+1, i ) - xi*temp
b( i, j ) = temp
b( j+1, i ) = zero
end do
b( j+1, j-1 ) = wi
b( j-1, j-1 ) = b( j-1, j-1 ) + xi*wi
b( j, j-1 ) = b( j, j-1 ) - xr*wi
else
! eliminate without interchange.
if( absbjj==zero ) then
b( j, j ) = eps3
b( j+1, j ) = zero
absbjj = eps3
end if
ej = ( ej / absbjj ) / absbjj
xr = b( j, j )*ej
xi = -b( j+1, j )*ej
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - xr*b( i, j ) +xi*b( j+1, i )
b( j, i ) = -xr*b( j+1, i ) - xi*b( i, j )
end do
b( j, j-1 ) = b( j, j-1 ) + wi
end if
! compute 1-norm of offdiagonal elements of j-th column.
work( j ) = stdlib${ii}$_${ri}$asum( j-1, b( 1_${ik}$, j ), 1_${ik}$ ) +stdlib${ii}$_${ri}$asum( j-1, b( j+1, 1_${ik}$ ),&
ldb )
end do loop_210
if( b( 1_${ik}$, 1_${ik}$ )==zero .and. b( 2_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3
work( 1_${ik}$ ) = zero
i1 = 1_${ik}$
i2 = n
i3 = 1_${ik}$
end if
loop_270: do its = 1, n
scale = one
vmax = one
vcrit = bignum
! solve u*(xr,xi) = scale*(vr,vi) for a right eigenvector,
! or u**t*(xr,xi) = scale*(vr,vi) for a left eigenvector,
! overwriting (xr,xi) on (vr,vi).
loop_250: do i = i1, i2, i3
if( work( i )>vcrit ) then
rec = one / vmax
call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ )
scale = scale*rec
vmax = one
vcrit = bignum
end if
xr = vr( i )
xi = vi( i )
if( rightv ) then
do j = i + 1, n
xr = xr - b( i, j )*vr( j ) + b( j+1, i )*vi( j )
xi = xi - b( i, j )*vi( j ) - b( j+1, i )*vr( j )
end do
else
do j = 1, i - 1
xr = xr - b( j, i )*vr( j ) + b( i+1, j )*vi( j )
xi = xi - b( j, i )*vi( j ) - b( i+1, j )*vr( j )
end do
end if
w = abs( b( i, i ) ) + abs( b( i+1, i ) )
if( w>smlnum ) then
if( w<one ) then
w1 = abs( xr ) + abs( xi )
if( w1>w*bignum ) then
rec = one / w1
call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ )
xr = vr( i )
xi = vi( i )
scale = scale*rec
vmax = vmax*rec
end if
end if
! divide by diagonal element of b.
call stdlib${ii}$_${ri}$ladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) )
vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax )
vcrit = bignum / vmax
else
do j = 1, n
vr( j ) = zero
vi( j ) = zero
end do
vr( i ) = one
vi( i ) = one
scale = zero
vmax = one
vcrit = bignum
end if
end do loop_250
! test for sufficient growth in the norm of (vr,vi).
vnorm = stdlib${ii}$_${ri}$asum( n, vr, 1_${ik}$ ) + stdlib${ii}$_${ri}$asum( n, vi, 1_${ik}$ )
if( vnorm>=growto*scale )go to 280
! choose a new orthogonal starting vector and try again.
y = eps3 / ( rootn+one )
vr( 1_${ik}$ ) = eps3
vi( 1_${ik}$ ) = zero
do i = 2, n
vr( i ) = y
vi( i ) = zero
end do
vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
end do loop_270
! failure to find eigenvector in n iterations
info = 1_${ik}$
280 continue
! normalize eigenvector.
vnorm = zero
do i = 1, n
vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) )
end do
call stdlib${ii}$_${ri}$scal( n, one / vnorm, vr, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, one / vnorm, vi, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$laein
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, smlnum, &
!! CLAEIN uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue W of a complex upper Hessenberg
!! matrix H.
info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(sp), intent(in) :: eps3, smlnum
complex(sp), intent(in) :: w
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(out) :: b(ldb,*)
complex(sp), intent(in) :: h(ldh,*)
complex(sp), intent(inout) :: v(*)
! =====================================================================
! Parameters
real(sp), parameter :: tenth = 1.0e-1_sp
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, ierr, its, j
real(sp) :: growto, nrmsml, rootn, rtemp, scale, vnorm
complex(sp) :: cdum, ei, ej, temp, x
! Intrinsic Functions
! Statement Functions
real(sp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) )
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=sp) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - w*i (except that the subdiagonal elements are not
! stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - w
end do
if( noinit ) then
! initialize v.
do i = 1, n
v( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_scnrm2( n, v, 1_${ik}$ )
call stdlib${ii}$_csscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), v, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( cabs1( b( i, i ) )<cabs1( ei ) ) then
! interchange rows and eliminate.
x = stdlib${ii}$_cladiv( b( i, i ), ei )
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==czero )b( i, i ) = eps3
x = stdlib${ii}$_cladiv( ei, b( i, i ) )
if( x/=czero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==czero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( cabs1( b( j, j ) )<cabs1( ej ) ) then
! interchange columns and eliminate.
x = stdlib${ii}$_cladiv( b( j, j ), ej )
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==czero )b( j, j ) = eps3
x = stdlib${ii}$_cladiv( ej, b( j, j ) )
if( x/=czero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==czero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'C'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**h *x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_clatrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb, v,scale, rwork, &
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_scasum( n, v, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
rtemp = eps3 / ( rootn+one )
v( 1_${ik}$ ) = eps3
do i = 2, n
v( i ) = rtemp
end do
v( n-its+1 ) = v( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_icamax( n, v, 1_${ik}$ )
call stdlib${ii}$_csscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ )
return
end subroutine stdlib${ii}$_claein
pure module subroutine stdlib${ii}$_zlaein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, smlnum, &
!! ZLAEIN uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue W of a complex upper Hessenberg
!! matrix H.
info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(dp), intent(in) :: eps3, smlnum
complex(dp), intent(in) :: w
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(out) :: b(ldb,*)
complex(dp), intent(in) :: h(ldh,*)
complex(dp), intent(inout) :: v(*)
! =====================================================================
! Parameters
real(dp), parameter :: tenth = 1.0e-1_dp
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, ierr, its, j
real(dp) :: growto, nrmsml, rootn, rtemp, scale, vnorm
complex(dp) :: cdum, ei, ej, temp, x
! Intrinsic Functions
! Statement Functions
real(dp) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) )
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=dp) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - w*i (except that the subdiagonal elements are not
! stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - w
end do
if( noinit ) then
! initialize v.
do i = 1, n
v( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_dznrm2( n, v, 1_${ik}$ )
call stdlib${ii}$_zdscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), v, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( cabs1( b( i, i ) )<cabs1( ei ) ) then
! interchange rows and eliminate.
x = stdlib${ii}$_zladiv( b( i, i ), ei )
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==czero )b( i, i ) = eps3
x = stdlib${ii}$_zladiv( ei, b( i, i ) )
if( x/=czero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==czero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( cabs1( b( j, j ) )<cabs1( ej ) ) then
! interchange columns and eliminate.
x = stdlib${ii}$_zladiv( b( j, j ), ej )
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==czero )b( j, j ) = eps3
x = stdlib${ii}$_zladiv( ej, b( j, j ) )
if( x/=czero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==czero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'C'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**h *x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_zlatrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb, v,scale, rwork, &
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_dzasum( n, v, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
rtemp = eps3 / ( rootn+one )
v( 1_${ik}$ ) = eps3
do i = 2, n
v( i ) = rtemp
end do
v( n-its+1 ) = v( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_izamax( n, v, 1_${ik}$ )
call stdlib${ii}$_zdscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ )
return
end subroutine stdlib${ii}$_zlaein
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, smlnum, &
!! ZLAEIN: uses inverse iteration to find a right or left eigenvector
!! corresponding to the eigenvalue W of a complex upper Hessenberg
!! matrix H.
info )
! -- lapack auxiliary routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
logical(lk), intent(in) :: noinit, rightv
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldb, ldh, n
real(${ck}$), intent(in) :: eps3, smlnum
complex(${ck}$), intent(in) :: w
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(out) :: b(ldb,*)
complex(${ck}$), intent(in) :: h(ldh,*)
complex(${ck}$), intent(inout) :: v(*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: tenth = 1.0e-1_${ck}$
! Local Scalars
character :: normin, trans
integer(${ik}$) :: i, ierr, its, j
real(${ck}$) :: growto, nrmsml, rootn, rtemp, scale, vnorm
complex(${ck}$) :: cdum, ei, ej, temp, x
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: cabs1
! Statement Function Definitions
cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) )
! Executable Statements
info = 0_${ik}$
! growto is the threshold used in the acceptance test for an
! eigenvector.
rootn = sqrt( real( n,KIND=${ck}$) )
growto = tenth / rootn
nrmsml = max( one, eps3*rootn )*smlnum
! form b = h - w*i (except that the subdiagonal elements are not
! stored).
do j = 1, n
do i = 1, j - 1
b( i, j ) = h( i, j )
end do
b( j, j ) = h( j, j ) - w
end do
if( noinit ) then
! initialize v.
do i = 1, n
v( i ) = eps3
end do
else
! scale supplied initial vector.
vnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n, v, 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), v, 1_${ik}$ )
end if
if( rightv ) then
! lu decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do i = 1, n - 1
ei = h( i+1, i )
if( cabs1( b( i, i ) )<cabs1( ei ) ) then
! interchange rows and eliminate.
x = stdlib${ii}$_${ci}$ladiv( b( i, i ), ei )
b( i, i ) = ei
do j = i + 1, n
temp = b( i+1, j )
b( i+1, j ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( i, i )==czero )b( i, i ) = eps3
x = stdlib${ii}$_${ci}$ladiv( ei, b( i, i ) )
if( x/=czero ) then
do j = i + 1, n
b( i+1, j ) = b( i+1, j ) - x*b( i, j )
end do
end if
end if
end do
if( b( n, n )==czero )b( n, n ) = eps3
trans = 'N'
else
! ul decomposition with partial pivoting of b, replacing czero
! pivots by eps3.
do j = n, 2, -1
ej = h( j, j-1 )
if( cabs1( b( j, j ) )<cabs1( ej ) ) then
! interchange columns and eliminate.
x = stdlib${ii}$_${ci}$ladiv( b( j, j ), ej )
b( j, j ) = ej
do i = 1, j - 1
temp = b( i, j-1 )
b( i, j-1 ) = b( i, j ) - x*temp
b( i, j ) = temp
end do
else
! eliminate without interchange.
if( b( j, j )==czero )b( j, j ) = eps3
x = stdlib${ii}$_${ci}$ladiv( ej, b( j, j ) )
if( x/=czero ) then
do i = 1, j - 1
b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
end do
end if
end if
end do
if( b( 1_${ik}$, 1_${ik}$ )==czero )b( 1_${ik}$, 1_${ik}$ ) = eps3
trans = 'C'
end if
normin = 'N'
do its = 1, n
! solve u*x = scale*v for a right eigenvector
! or u**h *x = scale*v for a left eigenvector,
! overwriting x on v.
call stdlib${ii}$_${ci}$latrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb, v,scale, rwork, &
ierr )
normin = 'Y'
! test for sufficient growth in the norm of v.
vnorm = stdlib${ii}$_${c2ri(ci)}$zasum( n, v, 1_${ik}$ )
if( vnorm>=growto*scale )go to 120
! choose new orthogonal starting vector and try again.
rtemp = eps3 / ( rootn+one )
v( 1_${ik}$ ) = eps3
do i = 2, n
v( i ) = rtemp
end do
v( n-its+1 ) = v( n-its+1 ) - eps3*rootn
end do
! failure to find eigenvector in n iterations.
info = 1_${ik}$
120 continue
! normalize eigenvector.
i = stdlib${ii}$_i${ci}$amax( n, v, 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ )
return
end subroutine stdlib${ii}$_${ci}$laein
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_gen2
