#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_gen
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! SGEEV computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_strevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_strevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_slacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_shseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_strevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_sgebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_sgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgeev
module subroutine stdlib${ii}$_dgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! DGEEV computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_dtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_dtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_dlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_dhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_dtrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_dgebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_dgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgeev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, &
!! DGEEV: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, &
minwrk, nout
real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -9_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else if( wantvr ) then
minwrk = 4_${ik}$*n
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
call stdlib${ii}$_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,&
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
maxwrk = max( maxwrk, 4_${ik}$*n )
else
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + 1_${ik}$, n + hswork )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = ibal + n
iwrk = itau + n
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ri}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ri}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 4*n, prefer n + n + 2*n*nb)
call stdlib${ii}$_${ri}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$geev
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! CGEEV computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(sp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(sp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ctrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ctrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_chseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_clacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_chseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_ctrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=sp)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_cscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=sp)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_cscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeev
module subroutine stdlib${ii}$_zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(dp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(dp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ztrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_ztrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_zhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_zlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_zhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_ztrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=dp)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_zscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=dp)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_zscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, &
!! ZGEEV: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr
character :: side
integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, &
maxwrk, minwrk, nout
real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum
complex(${ck}$) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -8_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
if( wantvl ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
call stdlib${ii}$_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, hswork, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
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 = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ci}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ci}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need 2*n)
irwork = ibal + n
call stdlib${ii}$_${ci}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork( irwork ), n, ierr )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vl( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vl( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( irwork+k-1 ) = real( vr( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vr( k, i ) )&
**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork( irwork ), 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info>0_${ik}$ ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geev
#:endif
#:endfor
module subroutine stdlib${ii}$_sgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_sp of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_strevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_strevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_shseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_shseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_shseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_sgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_slange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_slacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_shseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_strevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_strsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_sgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_sgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, work, 1_${ik}$ )
call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgeevx
module subroutine stdlib${ii}$_dgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_dp of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_dtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_dtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_dhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_dhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_dhseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_dgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_dlange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_dlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_dhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_dtrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_dtrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_dgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_dgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, work, 1_${ik}$ )
call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgeevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, &
!! DGEEVX: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate-transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_${rk}$ of the LAPACK
!! Users' Guide.
ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(${rk}$), intent(out) :: abnrm
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),&
work(*), wr(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vl, ldvl,work, -1_${ik}$, &
info )
else if( wantvr ) then
call stdlib${ii}$_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, n + lwork_trevc )
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, wr, wi, vr, ldvr,work, -1_${ik}$, &
info )
else
if( wntsnn ) then
call stdlib${ii}$_${ri}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
else
call stdlib${ii}$_${ri}$hseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, wr, wi, vr,ldvr, work, -1_${ik}$, &
info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.wntsnn )minwrk = max( minwrk, n*n+6*n )
maxwrk = max( maxwrk, hswork )
if( .not.wntsnn )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
else
minwrk = 3_${ik}$*n
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )minwrk = max( minwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( ( .not.wntsnn ) .and. ( .not.wntsne ) )maxwrk = max( maxwrk, n*n + 6_${ik}$*n )
maxwrk = max( maxwrk, 3_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_${ri}$gebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_${ri}$lange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (workspace: need 2*n, prefer n+n*nb)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate orthogonal matrix in vl
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,work( iwrk ), &
lwork-iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ri}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate orthogonal matrix in vr
! (workspace: need 2*n-1, prefer n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (workspace: need 1, prefer hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,work( iwrk ), &
lwork-iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ri}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (workspace: need 3*n, prefer n + 2*n*nb)
call stdlib${ii}$_${ri}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1, ierr )
end if
! compute condition numbers if desired
! (workspace: need n*n+6*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_${ri}$trsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, iwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_${ri}$gebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vl( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vl( k, i+1 ) = zero
end if
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_${ri}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
if( wi( i )==zero ) then
scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
else if( wi( i )>zero ) then
scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, &
vr( 1_${ik}$, i+1 ), 1_${ik}$ ) )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ )
do k = 1, n
work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$
end do
k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ )
call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn )
vr( k, i+1 ) = zero
end if
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ &
), ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$geevx
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_sp of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm
! Array Arguments
real(sp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(sp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(sp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_ctrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_ctrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_chseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_chseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_chseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_cgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_clange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_clacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_chseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_ctrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_ctrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_cgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=sp)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_cscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_cgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_scnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_csscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=sp)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_cscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=sp), zero,KIND=sp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeevx
module subroutine stdlib${ii}$_zgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_dp of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm
! Array Arguments
real(dp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(dp) :: anrm, bignum, cscale, eps, scl, smlnum
complex(dp) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_ztrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_ztrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_zhseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_zhseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_zhseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_zgebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_zlange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_zlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_zhseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_ztrevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_ztrsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_zgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=dp)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_zscal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_zgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_dznrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_zdscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=dp)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_zscal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=dp), zero,KIND=dp)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, &
!! ZGEEVX: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues and, optionally, the left and/or right eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!! (RCONDE), and reciprocal condition numbers for the right
!! eigenvectors (RCONDV).
!! The right eigenvector v(j) of A satisfies
!! A * v(j) = lambda(j) * v(j)
!! where lambda(j) is its eigenvalue.
!! The left eigenvector u(j) of A satisfies
!! u(j)**H * A = lambda(j) * u(j)**H
!! where u(j)**H denotes the conjugate transpose of u(j).
!! The computed eigenvectors are normalized to have Euclidean norm
!! equal to 1 and largest component real.
!! Balancing a matrix means permuting the rows and columns to make it
!! more nearly upper triangular, and applying a diagonal similarity
!! transformation D * A * D**(-1), where D is a diagonal matrix, to
!! make its rows and columns closer in norm and the condition numbers
!! of its eigenvalues and eigenvectors smaller. The computed
!! reciprocal condition numbers correspond to the balanced matrix.
!! Permuting rows and columns will not change the condition numbers
!! (in exact arithmetic) but diagonal scaling will. For further
!! explanation of balancing, see section 4.10.2_${ck}$ of the LAPACK
!! Users' Guide.
ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n
real(${ck}$), intent(out) :: abnrm
! Array Arguments
real(${ck}$), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv
character :: job, side
integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, &
nout
real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum
complex(${ck}$) :: tmp
! Local Arrays
logical(lk) :: select(1_${ik}$)
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvl = stdlib_lsame( jobvl, 'V' )
wantvr = stdlib_lsame( jobvr, 'V' )
wntsnn = stdlib_lsame( sense, 'N' )
wntsne = stdlib_lsame( sense, 'E' )
wntsnv = stdlib_lsame( sense, 'V' )
wntsnb = stdlib_lsame( sense, 'B' )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) &
.or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then
info = -2_${ik}$
else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then
info = -3_${ik}$
else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. &
wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( wantvl .and. ldvl<n ) ) then
info = -10_${ik}$
else if( ldvr<1_${ik}$ .or. ( wantvr .and. ldvr<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
if( wantvl ) then
call stdlib${ii}$_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vl, ldvl,work, -1_${ik}$, info )
else if( wantvr ) then
call stdlib${ii}$_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, &
work, -1_${ik}$, rwork, -1_${ik}$, ierr )
lwork_trevc = int( work(1_${ik}$),KIND=${ik}$)
maxwrk = max( maxwrk, lwork_trevc )
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
if( wntsnn ) then
call stdlib${ii}$_${ci}$hseqr( 'E', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
else
call stdlib${ii}$_${ci}$hseqr( 'S', 'N', n, 1_${ik}$, n, a, lda, w, vr, ldvr,work, -1_${ik}$, info )
end if
end if
hswork = int( work(1_${ik}$),KIND=${ik}$)
if( ( .not.wantvl ) .and. ( .not.wantvr ) ) then
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
else
minwrk = 2_${ik}$*n
if( .not.( wntsnn .or. wntsne ) )minwrk = max( minwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, hswork )
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
if( .not.( wntsnn .or. wntsne ) )maxwrk = max( maxwrk, n*n + 2_${ik}$*n )
maxwrk = max( maxwrk, 2_${ik}$*n )
end if
maxwrk = max( maxwrk, minwrk )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
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 = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
icond = 0_${ik}$
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! balance the matrix and compute abnrm
call stdlib${ii}$_${ci}$gebal( balanc, n, a, lda, ilo, ihi, scale, ierr )
abnrm = stdlib${ii}$_${ci}$lange( '1', n, n, a, lda, dum )
if( scalea ) then
dum( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
abnrm = dum( 1_${ik}$ )
end if
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = itau + n
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvl ) then
! want left eigenvectors
! copy householder vectors to vl
side = 'L'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vl, ldvl )
! generate unitary matrix in vl
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vl
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,work( iwrk ), lwork-&
iwrk+1, info )
if( wantvr ) then
! want left and right eigenvectors
! copy schur vectors to vr
side = 'B'
call stdlib${ii}$_${ci}$lacpy( 'F', n, n, vl, ldvl, vr, ldvr )
end if
else if( wantvr ) then
! want right eigenvectors
! copy householder vectors to vr
side = 'R'
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vr, ldvr )
! generate unitary matrix in vr
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
! perform qr iteration, accumulating schur vectors in vr
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
else
! compute eigenvalues only
! if condition numbers desired, compute schur form
if( wntsnn ) then
job = 'E'
else
job = 'S'
end if
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( job, 'N', n, ilo, ihi, a, lda, w, vr, ldvr,work( iwrk ), lwork-&
iwrk+1, info )
end if
! if info /= 0 from stdlib${ii}$_${ci}$hseqr, then quit
if( info/=0 )go to 50
if( wantvl .or. wantvr ) then
! compute left and/or right eigenvectors
! (cworkspace: need 2*n, prefer n + 2*n*nb)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$trevc3( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr,n, nout, work(&
iwrk ), lwork-iwrk+1,rwork, n, ierr )
end if
! compute condition numbers if desired
! (cworkspace: need n*n+2*n unless sense = 'e')
! (rworkspace: need 2*n unless sense = 'e')
if( .not.wntsnn ) then
call stdlib${ii}$_${ci}$trsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr,rconde, &
rcondv, n, nout, work( iwrk ), n, rwork,icond )
end if
if( wantvl ) then
! undo balancing of left eigenvectors
call stdlib${ii}$_${ci}$gebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl,ierr )
! normalize left eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vl( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vl( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
tmp = conjg( vl( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vl( 1_${ik}$, i ), 1_${ik}$ )
vl( k, i ) = cmplx( real( vl( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
if( wantvr ) then
! undo balancing of right eigenvectors
call stdlib${ii}$_${ci}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr )
! normalize right eigenvectors and make largest component real
do i = 1, n
scl = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ )
call stdlib${ii}$_${ci}$dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ )
do k = 1, n
rwork( k ) = real( vr( k, i ),KIND=${ck}$)**2_${ik}$ +aimag( vr( k, i ) )**2_${ik}$
end do
k = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ )
tmp = conjg( vr( k, i ) ) / sqrt( rwork( k ) )
call stdlib${ii}$_${ci}$scal( n, tmp, vr( 1_${ik}$, i ), 1_${ik}$ )
vr( k, i ) = cmplx( real( vr( k, i ),KIND=${ck}$), zero,KIND=${ck}$)
end do
end if
! undo scaling if necessary
50 continue
if( scalea ) then
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, w( info+1 ),max( n-info, 1_${ik}$ )&
, ierr )
if( info==0_${ik}$ ) then
if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale,&
anrm, n, 1_${ik}$, rcondv, n,ierr )
else
call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geevx
#:endif
#:endfor
module subroutine stdlib${ii}$_sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! SGEES computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_s) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_strsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sgees
module subroutine stdlib${ii}$_dgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! DGEES computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_d) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_dtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dgees
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$gees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, &
!! DGEES: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A matrix is in real Schur form if it is upper quasi-triangular with
!! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!! form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_${ri}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, maxwrk, minwrk
real(${rk}$) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (workspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (workspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (workspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (workspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (workspace: none needed)
call stdlib${ii}$_${ri}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, &
work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond )
if( icond>0_${ik}$ )info = n + icond
end if
if( wantvs ) then
! undo balancing
! (workspace: need n)
call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ )
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), &
ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
! undo scaling for the imaginary part of the eigenvalues
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$gees
#:endif
#:endfor
module subroutine stdlib${ii}$_cgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! CGEES computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_c) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_chseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=sp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_ctrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgees
module subroutine stdlib${ii}$_zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_z) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_zhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=dp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_ztrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgees
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$gees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, &
!! ZGEES: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left.
!! The leading columns of Z then form an orthonormal basis for the
!! invariant subspace corresponding to the selected eigenvalues.
!! A complex matrix is in Schur form if it is upper triangular.
rwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_${ci}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantst, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, &
minwrk
real(${ck}$) :: anrm, bignum, cscale, eps, s, sep, smlnum
! Local Arrays
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -10_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=${ck}$)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEES ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
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 = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues and transform schur vectors
! (cworkspace: none)
! (rworkspace: none)
call stdlib${ii}$_${ci}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( &
iwrk ), lwork-iwrk+1, icond )
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$gees
#:endif
#:endfor
module subroutine stdlib${ii}$_sgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! SGEESX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_sp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(sp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_s) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, lwrk, liwrk, maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_shseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_strsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_shseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_slacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_strsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_strsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = sdim*(n-sdim)
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_sgeesx
module subroutine stdlib${ii}$_dgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! DGEESX computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_dp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(dp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_d) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, liwrk, lwrk, maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_dhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_dtrsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_dhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_dgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_dlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_dorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_dhseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_dtrsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) )
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_dgeesx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$geesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, &
!! DGEESX: computes for an N-by-N real nonsymmetric matrix A, the
!! eigenvalues, the real Schur form T, and, optionally, the matrix of
!! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! real Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_${rk}$ of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A real matrix is in real Schur form if it is upper quasi-triangular
!! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!! the form
!! [ a b ]
!! [ c a ]
!! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
rconde, rcondv, work, lwork,iwork, liwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n
real(${rk}$), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*)
! Function Arguments
procedure(stdlib_select_${ri}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, &
wantsv, wantvs
integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, &
iwrk, liwrk, lwrk, maxwrk, minwrk
real(${rk}$) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(${rk}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -12_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "rworkspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! iworkspace refers to integer workspace.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ri}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_${ri}$trsen later
! in the code.)
if( info==0_${ik}$ ) then
liwrk = 1_${ik}$
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = 2_${ik}$*n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 3_${ik}$*n
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, wr, wi, vs, ldvs,work, -1_${ik}$, &
ieval )
hswork = work( 1_${ik}$ )
if( .not.wantvs ) then
maxwrk = max( maxwrk, n + hswork )
else
maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'DORGHR', ' ', n, 1_${ik}$, n,&
-1_${ik}$ ) )
maxwrk = max( maxwrk, n + hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, n + ( n*n )/2_${ik}$ )
if( wantsv .or. wantsb )liwrk = ( n*n )/4_${ik}$
end if
iwork( 1_${ik}$ ) = liwrk
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<1_${ik}$ .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ri}$gebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr )
! reduce to upper hessenberg form
! (rworkspace: need 3*n, prefer 2*n+n*nb)
itau = n + ibal
iwrk = n + itau
call stdlib${ii}$_${ri}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ri}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate orthogonal matrix in vs
! (rworkspace: need 3*n-1, prefer 2*n+(n-1)*nb)
call stdlib${ii}$_${ri}$orghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (rworkspace: need n+1, prefer n+hswork (see comments) )
iwrk = itau
call stdlib${ii}$_${ri}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs,work( iwrk ), &
lwork-iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr )
end if
do i = 1, n
bwork( i ) = select( wr( i ), wi( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (rworkspace: if sense is not 'n', need n+2*sdim*(n-sdim)
! otherwise, need n )
! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim)
! otherwise, need 0 )
call stdlib${ii}$_${ri}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond )
if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) )
if( icond==-15_${ik}$ ) then
! not enough real workspace
info = -16_${ik}$
else if( icond==-17_${ik}$ ) then
! not enough integer workspace
info = -18_${ik}$
else if( icond>0_${ik}$ ) then
! stdlib${ii}$_${ri}$trsen failed to reorder or to restore standard schur form
info = icond + n
end if
end if
if( wantvs ) then
! undo balancing
! (rworkspace: need n)
call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
if( cscale==smlnum ) then
! if scaling back towards underflow, adjust wi if an
! offdiagonal element of a 2-by-2 block in the schur form
! underflows.
if( ieval>0_${ik}$ ) then
i1 = ieval + 1_${ik}$
i2 = ihi - 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr )
else if( wantst ) then
i1 = 1_${ik}$
i2 = n - 1_${ik}$
else
i1 = ilo
i2 = ihi - 1_${ik}$
end if
inxt = i1 - 1_${ik}$
loop_20: do i = i1, i2
if( i<inxt )cycle loop_20
if( wi( i )==zero ) then
inxt = i + 1_${ik}$
else
if( a( i+1, i )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then
wi( i ) = zero
wi( i+1 ) = zero
if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), &
lda )
if( wantvs ) then
call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ )
end if
a( i, i+1 ) = a( i+1, i )
a( i+1, i ) = zero
end if
inxt = i + 2_${ik}$
end if
end do loop_20
end if
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,&
1_${ik}$ ), ierr )
end if
if( wantst .and. info==0_${ik}$ ) then
! check if reordering successful
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = select( wr( i ), wi( i ) )
if( wi( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
work( 1_${ik}$ ) = maxwrk
if( wantsv .or. wantsb ) then
iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) )
else
iwork( 1_${ik}$ ) = 1_${ik}$
end if
return
end subroutine stdlib${ii}$_${ri}$geesx
#:endif
#:endfor
module subroutine stdlib${ii}$_cgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! CGEESX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_sp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(sp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_c) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(sp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(sp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_chseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_ctrsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_chseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=sp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_cgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_clacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_cunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_chseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_ctrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cgeesx
module subroutine stdlib${ii}$_zgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_dp of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(dp), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_z) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(dp) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(dp) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_zhseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_ztrsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_zhseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=dp)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_zgebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_zlacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_zunghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_zhseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_ztrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zgeesx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$geesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, &
!! ZGEESX: computes for an N-by-N complex nonsymmetric matrix A, the
!! eigenvalues, the Schur form T, and, optionally, the matrix of Schur
!! vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
!! Optionally, it also orders the eigenvalues on the diagonal of the
!! Schur form so that selected eigenvalues are at the top left;
!! computes a reciprocal condition number for the average of the
!! selected eigenvalues (RCONDE); and computes a reciprocal condition
!! number for the right invariant subspace corresponding to the
!! selected eigenvalues (RCONDV). The leading columns of Z form an
!! orthonormal basis for this invariant subspace.
!! For further explanation of the reciprocal condition numbers RCONDE
!! and RCONDV, see Section 4.10_${ck}$ of the LAPACK Users' Guide (where
!! these quantities are called s and sep respectively).
!! A complex matrix is in Schur form if it is upper triangular.
rcondv, work, lwork, rwork,bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvs, sense, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldvs, lwork, n
real(${ck}$), intent(out) :: rconde, rcondv
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: vs(ldvs,*), w(*), work(*)
! Function Arguments
procedure(stdlib_select_${ci}$) :: select
! =====================================================================
! Local Scalars
logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs
integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, &
maxwrk, minwrk
real(${ck}$) :: anrm, bignum, cscale, eps, smlnum
! Local Arrays
real(${ck}$) :: dum(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
wantvs = stdlib_lsame( jobvs, 'V' )
wantst = stdlib_lsame( sort, 'S' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
lquery = ( lwork==-1_${ik}$ )
if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then
info = -1_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. &
.not.wantsn ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvs<1_${ik}$ .or. ( wantvs .and. ldvs<n ) ) then
info = -11_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of real workspace needed at that point in the
! code, as well as the preferred amount for good performance.
! cworkspace refers to complex workspace, and rworkspace to real
! workspace. nb refers to the optimal block size for the
! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.
! hswork refers to the workspace preferred by stdlib${ii}$_${ci}$hseqr, as
! calculated below. hswork is computed assuming ilo=1 and ihi=n,
! the worst case.
! if sense = 'e', 'v' or 'b', then the amount of workspace needed
! depends on sdim, which is computed by the routine stdlib${ii}$_${ci}$trsen later
! in the code.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
lwrk = 1_${ik}$
else
maxwrk = n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEHRD', ' ', n, 1_${ik}$, n, 0_${ik}$ )
minwrk = 2_${ik}$*n
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, 1_${ik}$, n, a, lda, w, vs, ldvs,work, -1_${ik}$, ieval )
hswork = real( work( 1_${ik}$ ),KIND=${ck}$)
if( .not.wantvs ) then
maxwrk = max( maxwrk, hswork )
else
maxwrk = max( maxwrk, n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGHR',' ', n, 1_${ik}$, n, -&
1_${ik}$ ) )
maxwrk = max( maxwrk, hswork )
end if
lwrk = maxwrk
if( .not.wantsn )lwrk = max( lwrk, ( n*n )/2_${ik}$ )
end if
work( 1_${ik}$ ) = lwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGEESX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
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 = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, dum )
scalea = .false.
if( anrm>zero .and. anrm<smlnum ) then
scalea = .true.
cscale = smlnum
else if( anrm>bignum ) then
scalea = .true.
cscale = bignum
end if
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, cscale, n, n, a, lda, ierr )
! permute the matrix to make it more nearly triangular
! (cworkspace: none)
! (rworkspace: need n)
ibal = 1_${ik}$
call stdlib${ii}$_${ci}$gebal( 'P', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
! reduce to upper hessenberg form
! (cworkspace: need 2*n, prefer n+n*nb)
! (rworkspace: none)
itau = 1_${ik}$
iwrk = n + itau
call stdlib${ii}$_${ci}$gehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),lwork-iwrk+1, ierr &
)
if( wantvs ) then
! copy householder vectors to vs
call stdlib${ii}$_${ci}$lacpy( 'L', n, n, a, lda, vs, ldvs )
! generate unitary matrix in vs
! (cworkspace: need 2*n-1, prefer n+(n-1)*nb)
! (rworkspace: none)
call stdlib${ii}$_${ci}$unghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ),lwork-iwrk+1, &
ierr )
end if
sdim = 0_${ik}$
! perform qr iteration, accumulating schur vectors in vs if desired
! (cworkspace: need 1, prefer hswork (see comments) )
! (rworkspace: none)
iwrk = itau
call stdlib${ii}$_${ci}$hseqr( 'S', jobvs, n, ilo, ihi, a, lda, w, vs, ldvs,work( iwrk ), lwork-&
iwrk+1, ieval )
if( ieval>0_${ik}$ )info = ieval
! sort eigenvalues if desired
if( wantst .and. info==0_${ik}$ ) then
if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr )
do i = 1, n
bwork( i ) = select( w( i ) )
end do
! reorder eigenvalues, transform schur vectors, and compute
! reciprocal condition numbers
! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim)
! otherwise, need none )
! (rworkspace: none)
call stdlib${ii}$_${ci}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, &
rcondv, work( iwrk ), lwork-iwrk+1,icond )
if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) )
if( icond==-14_${ik}$ ) then
! not enough complex workspace
info = -15_${ik}$
end if
end if
if( wantvs ) then
! undo balancing
! (cworkspace: none)
! (rworkspace: need n)
call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr )
end if
if( scalea ) then
! undo scaling for the schur form of a
call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ )
if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then
dum( 1_${ik}$ ) = rcondv
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr )
rcondv = dum( 1_${ik}$ )
end if
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$geesx
#:endif
#:endfor
module subroutine stdlib${ii}$_sggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! SGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_sgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, &
-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_sorgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_slaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_slaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = real( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_sgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_slaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = real( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_sggev3
module subroutine stdlib${ii}$_dggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_dgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max(1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_dorgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_dgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_dgghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_dgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dggev3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,&
!! DGGEV3: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork,info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, lwkopt
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
else if( lwork<max( 1_${ik}$, 8_${ik}$*n ) .and. .not.lquery ) then
info = -16_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ri}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max(1_${ik}$, 8_${ik}$*n, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_${ri}$orgqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_${ri}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_${ri}$gghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_${ri}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ggev3
#:endif
#:endfor
module subroutine stdlib${ii}$_cggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! CGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_cgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( n, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_cunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_cungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_cgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_cgghd3( 'N', 'N', n, 1_${ik}$, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, work, -&
1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'E' )*stdlib${ii}$_slamch( 'B' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk,ierr )
else
call stdlib${ii}$_cgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_claqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
return
end subroutine stdlib${ii}$_cggev3
module subroutine stdlib${ii}$_zggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_zgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_zungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zlaqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_zlaqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'E' )*stdlib${ii}$_dlamch( 'B' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_zgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp)
return
end subroutine stdlib${ii}$_zggev3
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV3: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -15_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ci}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvl ) then
call stdlib${ii}$_${ci}$ungqr( n, n, n, vl, ldvl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
if( ilv ) then
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$laqz0( 'S', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
else
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ci}$laqz0( 'E', jobvl, jobvr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )*stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
work( iwrk ), lwork+1-iwrk, ierr )
else
call stdlib${ii}$_${ci}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$)
return
end subroutine stdlib${ii}$_${ci}$ggev3
#:endif
#:endfor
module subroutine stdlib${ii}$_sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sggev
module subroutine stdlib${ii}$_dggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dggev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, &
!! DGGEV: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B .
!! where u(j)**H is the conjugate-transpose of u(j).
ldvr, work, lwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, &
iwrk, jc, jr, maxwrk, minwrk
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -12_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -14_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
minwrk = max( 1_${ik}$, 8_${ik}$*n )
maxwrk = max( 1_${ik}$, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) )
if( ilvl ) then
maxwrk = max( maxwrk, n*( 7_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) )
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery )info = -16_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 110
end if
! compute eigenvectors
! (workspace: need 6*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 110
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, &
ldvl, ierr )
loop_50: do jc = 1, n
if( alphai( jc )<zero )cycle loop_50
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_50
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, vr, &
ldvr, ierr )
loop_100: do jc = 1, n
if( alphai( jc )<zero )cycle loop_100
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_100
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_100
end if
! end of eigenvector calculation
end if
! undo scaling if necessary
110 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$ggev
#:endif
#:endfor
module subroutine stdlib${ii}$_cggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! CGGEV computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'E' )*stdlib${ii}$_slamch( 'B' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cggev
module subroutine stdlib${ii}$_zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'E' )*stdlib${ii}$_dlamch( 'B' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_zggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zggev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, &
!! ZGGEV: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right generalized eigenvector v(j) corresponding to the
!! generalized eigenvalue lambda(j) of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j).
!! The left generalized eigenvector u(j) corresponding to the
!! generalized eigenvalues lambda(j) of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B
!! where u(j)**H is the conjugate-transpose of u(j).
work, lwork, rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvl, jobvr
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery
character :: chtemp
integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,&
itau, iwrk, jc, jr, lwkmin, lwkopt
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -11_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -13_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 2_${ik}$*n )
lwkopt = max( 1_${ik}$, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
lwkopt = max( lwkopt, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) )
end if
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery )info = -15_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )*stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrices a, b to isolate eigenvalues if possible
! (real workspace: need 6*n)
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_${ci}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb)
irows = ihi + 1_${ik}$ - ilo
if( ilv ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl
! (complex workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vr
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
if( ilv ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur form and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 70
end if
! compute eigenvectors
! (real workspace: need 2*n)
! (complex workspace: need 2*n)
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, &
in, work( iwrk ), rwork( irwrk ),ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 70
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,&
ldvl, ierr )
loop_30: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_30
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_30
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,&
ldvr, ierr )
loop_60: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_60
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_60
end if
end if
! undo scaling if necessary
70 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$ggev
#:endif
#:endfor
module subroutine stdlib${ii}$_sggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc, 'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse ) then
minwrk = 10_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_sggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_slange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_slange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_stgevc: need 6*n
! stdlib${ii}$_stgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_stgevc) and estimate condition
! numbers (stdlib${ii}$_stgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_stgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_stgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_sggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_sggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_sggevx
module subroutine stdlib${ii}$_dggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc,'S' ) .or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse .or. wantsb ) then
minwrk = 10_${ik}$*n
end if
if( wantsv .or. wantsb ) then
minwrk = max( minwrk, 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$ )
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_dggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_dlange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_dlange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_dtgevc: need 6*n
! stdlib${ii}$_dtgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_dtgevc) and estimate condition
! numbers (stdlib${ii}$_dtgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_dtgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_dtgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_dggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_dggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_dggevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alphar, alphai, &
!! DGGEVX: computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!! the generalized eigenvalues, and optionally, the left and/or right
!! generalized eigenvectors.
!! Optionally also, it computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
beta, vl, ldvl, vr, ldvr, ilo,ihi, lscale, rscale, abnrm, bbnrm, rconde,rcondv, work, lwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(${rk}$), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), lscale(*), rconde(*), rcondv(*)&
, rscale(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, pair, wantsb, wantse, &
wantsn, wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk, mm
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc,'S' ) .or. &
stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -14_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -16_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
if( noscl .and. .not.ilv ) then
minwrk = 2_${ik}$*n
else
minwrk = 6_${ik}$*n
end if
if( wantse .or. wantsb ) then
minwrk = 10_${ik}$*n
end if
if( wantsv .or. wantsb ) then
minwrk = max( minwrk, 2_${ik}$*n*( n + 4_${ik}$ ) + 16_${ik}$ )
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -26_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_${ri}$labad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_${ri}$ggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,work, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_${ri}$lange( '1', n, n, a, lda, work( 1_${ik}$ ) )
if( ilascl ) then
work( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = work( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_${ri}$lange( '1', n, n, b, ldb, work( 1_${ik}$ ) )
if( ilbscl ) then
work( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = work( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to a
! (workspace: need n, prefer n*nb)
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (workspace: need n)
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vl, ldvl, vr, ldvr, work,lwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 130
end if
! compute eigenvectors and estimate condition numbers if desired
! (workspace: stdlib${ii}$_${ri}$tgevc: need 6*n
! stdlib${ii}$_${ri}$tgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b',
! need n otherwise )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_${ri}$tgevc) and estimate condition
! numbers (stdlib${ii}$_${ri}$tgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to recalculate
! eigenvectors and estimate one condition numbers at a time.
pair = .false.
loop_20: do i = 1, n
if( pair ) then
pair = .false.
cycle loop_20
end if
mm = 1_${ik}$
if( i<n ) then
if( a( i+1, i )/=zero ) then
pair = .true.
mm = 2_${ik}$
end if
end if
do j = 1, n
bwork( j ) = .false.
end do
if( mm==1_${ik}$ ) then
bwork( i ) = .true.
else if( mm==2_${ik}$ ) then
bwork( i ) = .true.
bwork( i+1 ) = .true.
end if
iwrk = mm*n + 1_${ik}$
iwrk1 = iwrk + mm*n
! compute a pair of left and right eigenvectors.
! (compute workspace: need up to 4*n + 6*n)
if( wantse .or. wantsb ) then
call stdlib${ii}$_${ri}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, mm, m,work( iwrk1 ), ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 130
end if
end if
call stdlib${ii}$_${ri}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,&
ierr )
end do loop_20
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ri}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_70: do jc = 1, n
if( alphai( jc )<zero )cycle loop_70
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vl( jr, jc ) )+abs( vl( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_70
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
else
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
end do
end if
end do loop_70
end if
if( ilvr ) then
call stdlib${ii}$_${ri}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_120: do jc = 1, n
if( alphai( jc )<zero )cycle loop_120
temp = zero
if( alphai( jc )==zero ) then
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) ) )
end do
else
do jr = 1, n
temp = max( temp, abs( vr( jr, jc ) )+abs( vr( jr, jc+1 ) ) )
end do
end if
if( temp<smlnum )cycle loop_120
temp = one / temp
if( alphai( jc )==zero ) then
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
else
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
end do
end if
end do loop_120
end if
! undo scaling if necessary
130 continue
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ri}$ggevx
#:endif
#:endfor
module subroutine stdlib${ii}$_cggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(sp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(sp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(sp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=sp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_cggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_clange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_clange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_ctgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_ctgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_ctgevc) and estimate condition
! numbers (stdlib${ii}$_ctgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_ctgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_ctgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_cggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_cggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_cggevx
module subroutine stdlib${ii}$_zggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(dp), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(dp) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(dp) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=dp) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
smlnum = stdlib${ii}$_dlamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_dlabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_zlange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_zggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_zlange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_zlange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_zunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_ztgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_ztgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_ztgevc) and estimate condition
! numbers (stdlib${ii}$_ztgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_ztgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_ztgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_zggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_zggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_zggevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, &
!! ZGGEVX: computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B) the generalized eigenvalues, and optionally, the left and/or
!! right generalized eigenvectors.
!! Optionally, it also computes a balancing transformation to improve
!! the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!! the eigenvalues (RCONDE), and reciprocal condition numbers for the
!! right eigenvectors (RCONDV).
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!! lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!! singular. It is usually represented as the pair (alpha,beta), as
!! there is a reasonable interpretation for beta=0, and even for both
!! being zero.
!! The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! A * v(j) = lambda(j) * B * v(j) .
!! The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!! of (A,B) satisfies
!! u(j)**H * A = lambda(j) * u(j)**H * B.
!! where u(j)**H is the conjugate-transpose of u(j).
ldvl, vr, ldvr, ilo, ihi,lscale, rscale, abnrm, bbnrm, rconde, rcondv,work, lwork, rwork, &
iwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: balanc, jobvl, jobvr, sense
integer(${ik}$), intent(out) :: ihi, ilo, info
integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n
real(${ck}$), intent(out) :: abnrm, bbnrm
! Array Arguments
logical(lk), intent(out) :: bwork(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, &
wantsv
character :: chtemp
integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, &
jr, m, maxwrk, minwrk
real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp
complex(${ck}$) :: x
! Local Arrays
logical(lk) :: ldumma(1_${ik}$)
! Intrinsic Functions
! Statement Functions
real(${ck}$) :: abs1
! Statement Function Definitions
abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) )
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvl = .false.
else if( stdlib_lsame( jobvl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvl = .true.
else
ijobvl = -1_${ik}$
ilvl = .false.
end if
if( stdlib_lsame( jobvr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvr = .false.
else if( stdlib_lsame( jobvr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvr = .true.
else
ijobvr = -1_${ik}$
ilvr = .false.
end if
ilv = ilvl .or. ilvr
noscl = stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'P' )
wantsn = stdlib_lsame( sense, 'N' )
wantse = stdlib_lsame( sense, 'E' )
wantsv = stdlib_lsame( sense, 'V' )
wantsb = stdlib_lsame( sense, 'B' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) &
then
info = -1_${ik}$
else if( ijobvl<=0_${ik}$ ) then
info = -2_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -3_${ik}$
else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvl<1_${ik}$ .or. ( ilvl .and. ldvl<n ) ) then
info = -13_${ik}$
else if( ldvr<1_${ik}$ .or. ( ilvr .and. ldvr<n ) ) then
info = -15_${ik}$
end if
! compute workspace
! (note: comments in the code beginning "workspace:" describe the
! minimal amount of workspace needed at that point in the code,
! as well as the preferred amount for good performance.
! nb refers to the optimal block size for the immediately
! following subroutine, as returned by stdlib${ii}$_ilaenv. the workspace is
! computed assuming ilo = 1 and ihi = n, the worst case.)
if( info==0_${ik}$ ) then
if( n==0_${ik}$ ) then
minwrk = 1_${ik}$
maxwrk = 1_${ik}$
else
minwrk = 2_${ik}$*n
if( wantse ) then
minwrk = 4_${ik}$*n
else if( wantsv .or. wantsb ) then
minwrk = 2_${ik}$*n*( n + 1_${ik}$)
end if
maxwrk = minwrk
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
maxwrk = max( maxwrk,n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
if( ilvl ) then
maxwrk = max( maxwrk, n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, 0_${ik}$ ) )
end if
end if
work( 1_${ik}$ ) = maxwrk
if( lwork<minwrk .and. .not.lquery ) then
info = -25_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZGGEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! get machine constants
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 = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ci}$lange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute and/or balance the matrix pair (a,b)
! (real workspace: need 6*n if balanc = 's' or 'b', 1 otherwise)
call stdlib${ii}$_${ci}$ggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale,rwork, ierr )
! compute abnrm and bbnrm
abnrm = stdlib${ii}$_${ci}$lange( '1', n, n, a, lda, rwork( 1_${ik}$ ) )
if( ilascl ) then
rwork( 1_${ik}$ ) = abnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
abnrm = rwork( 1_${ik}$ )
end if
bbnrm = stdlib${ii}$_${ci}$lange( '1', n, n, b, ldb, rwork( 1_${ik}$ ) )
if( ilbscl ) then
rwork( 1_${ik}$ ) = bbnrm
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, 1_${ik}$, 1_${ik}$, rwork( 1_${ik}$ ), 1_${ik}$,ierr )
bbnrm = rwork( 1_${ik}$ )
end if
! reduce b to triangular form (qr decomposition of b)
! (complex workspace: need n, prefer n*nb )
irows = ihi + 1_${ik}$ - ilo
if( ilv .or. .not.wantsn ) then
icols = n + 1_${ik}$ - ilo
else
icols = irows
end if
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_${ci}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the unitary transformation to a
! (complex workspace: need n, prefer n*nb)
call stdlib${ii}$_${ci}$unmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vl and/or vr
! (workspace: need n, prefer n*nb)
if( ilvl ) then
call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),&
ldvl )
end if
call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr )
! reduce to generalized hessenberg form
! (workspace: none needed)
if( ilv .or. .not.wantsn ) then
! eigenvectors requested -- work on whole matrix.
call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, &
ierr )
else
call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), &
ldb, vl, ldvl, vr, ldvr, ierr )
end if
! perform qz algorithm (compute eigenvalues, and optionally, the
! schur forms and schur vectors)
! (complex workspace: need n)
! (real workspace: need n)
iwrk = itau
if( ilv .or. .not.wantsn ) then
chtemp = 'S'
else
chtemp = 'E'
end if
call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, &
ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 90
end if
! compute eigenvectors and estimate condition numbers if desired
! stdlib${ii}$_${ci}$tgevc: (complex workspace: need 2*n )
! (real workspace: need 2*n )
! stdlib${ii}$_${ci}$tgsna: (complex workspace: need 2*n*n if sense='v' or 'b')
! (integer workspace: need n+2 )
if( ilv .or. .not.wantsn ) then
if( ilv ) then
if( ilvl ) then
if( ilvr ) then
chtemp = 'B'
else
chtemp = 'L'
end if
else
chtemp = 'R'
end if
call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,&
in, work( iwrk ), rwork,ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
if( .not.wantsn ) then
! compute eigenvectors (stdlib${ii}$_${ci}$tgevc) and estimate condition
! numbers (stdlib${ii}$_${ci}$tgsna). note that the definition of the condition
! number is not invariant under transformation (u,v) to
! (q*u, z*v), where (u,v) are eigenvectors of the generalized
! schur form (s,t), q and z are orthogonal matrices. in order
! to avoid using extra 2*n*n workspace, we have to
! re-calculate eigenvectors and estimate the condition numbers
! one at a time.
do i = 1, n
do j = 1, n
bwork( j ) = .false.
end do
bwork( i ) = .true.
iwrk = n + 1_${ik}$
iwrk1 = iwrk + n
if( wantse .or. wantsb ) then
call stdlib${ii}$_${ci}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr )
if( ierr/=0_${ik}$ ) then
info = n + 2_${ik}$
go to 90
end if
end if
call stdlib${ii}$_${ci}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( &
iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, &
ierr )
end do
end if
end if
! undo balancing on vl and vr and normalization
! (workspace: none needed)
if( ilvl ) then
call stdlib${ii}$_${ci}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr )
loop_50: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vl( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_50
temp = one / temp
do jr = 1, n
vl( jr, jc ) = vl( jr, jc )*temp
end do
end do loop_50
end if
if( ilvr ) then
call stdlib${ii}$_${ci}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr )
loop_80: do jc = 1, n
temp = zero
do jr = 1, n
temp = max( temp, abs1( vr( jr, jc ) ) )
end do
if( temp<smlnum )cycle loop_80
temp = one / temp
do jr = 1, n
vr( jr, jc ) = vr( jr, jc )*temp
end do
end do loop_80
end if
! undo scaling if necessary
90 continue
if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
work( 1_${ik}$ ) = maxwrk
return
end subroutine stdlib${ii}$_${ci}$ggevx
#:endif
#:endfor
module subroutine stdlib${ii}$_sgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! SGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! SGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_s) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_sgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_sormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_sorgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_sgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_slaqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_slabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_slange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_slange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_sgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_slaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 40
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphar( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i )/alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphai( i ) )>( &
anrm/anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i+1 )/alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl )then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i )/safmax )>( bnrmto/bnrm ) .or.( safmin/beta( i ) )>( &
bnrm/bnrmto ) ) then
work( 1_${ik}$ ) = abs(b( i, i )/beta( i ))
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sgges3
module subroutine stdlib${ii}$_dgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_d) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(dp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_dgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_dorgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_dgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_dlaqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_dlamch( 'P' )
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_dlabad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_dlange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_dlange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_dggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_dormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_dgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk,ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_dlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dgges3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, &
!! DGGES3: computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!! the generalized eigenvalues, the generalized real Schur form (S,T),
!! optionally, the left and/or right matrices of Schur vectors (VSL and
!! VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! quasi-triangular matrix S and the upper triangular matrix T.The
!! leading columns of VSL and VSR then form an orthonormal basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! DGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0 or both being zero.
!! A pair of matrices (S,T) is in generalized real Schur form if T is
!! upper triangular with non-negative diagonal and S is block upper
!! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
!! to real generalized eigenvalues, while 2-by-2 blocks of S will be
!! "standardized" by making the corresponding elements of T have the
!! form:
!! [ a 0 ]
!! [ 0 b ]
!! and the pair of corresponding 2-by-2 blocks in S and T will have a
!! complex conjugate pair of generalized eigenvalues.
alphai, beta, vsl, ldvsl,vsr, ldvsr, work, lwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), &
work(*)
! Function Arguments
procedure(stdlib_selctg_${ri}$) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, &
wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, &
itau, iwrk, lwkopt
real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, &
smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(${rk}$) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -15_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -17_${ik}$
else if( lwork<6_${ik}$*n+16 .and. .not.lquery ) then
info = -19_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_${ri}$geqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 6_${ik}$*n+16, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_${ri}$orgqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_${ri}$gghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, 3_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_${ri}$laqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work, -1_${ik}$, 0_${ik}$, ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$,ierr )
lwkopt = max( lwkopt, 2_${ik}$*n+int( work ( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_${ri}$lamch( 'P' )
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
call stdlib${ii}$_${ri}$labad( safmin, safmax )
smlnum = sqrt( safmin ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_${ri}$lange( 'M', n, n, b, ldb, work )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
iwrk = iright + n
call stdlib${ii}$_${ri}$ggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),work( iright ), &
work( iwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = iwrk
iwrk = itau + irows
call stdlib${ii}$_${ri}$geqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_${ri}$ormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_${ri}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk,ierr )
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_${ri}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, &
beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 50
end if
! sort eigenvalues alpha/beta if desired
sdim = 0_${ik}$
if( wantst ) then
! undo scaling on eigenvalues before selctging
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr )
end if
if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) )
end do
call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, &
vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,&
ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, &
vsr, ldvsr, ierr )
! check if unscaling would cause over/underflow, if so, rescale
! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of
! b(i,i) and alphar(i) and alphai(i) are on the order of a(i,i)
if( ilascl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( &
anrm / anrmto ) ) then
work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )&
)>( anrm / anrmto ) )then
work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
if( ilbscl ) then
do i = 1, n
if( alphai( i )/=zero ) then
if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( &
bnrm / bnrmto ) ) then
work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) )
beta( i ) = beta( i )*work( 1_${ik}$ )
alphar( i ) = alphar( i )*work( 1_${ik}$ )
alphai( i ) = alphai( i )*work( 1_${ik}$ )
end if
end if
end do
end if
! undo scaling
if( ilascl ) then
call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr )
end if
if( ilbscl ) then
call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr )
end if
if( wantst ) then
! check if reordering is correct
lastsl = .true.
lst2sl = .true.
sdim = 0_${ik}$
ip = 0_${ik}$
do i = 1, n
cursl = selctg( alphar( i ), alphai( i ), beta( i ) )
if( alphai( i )==zero ) then
if( cursl )sdim = sdim + 1_${ik}$
ip = 0_${ik}$
if( cursl .and. .not.lastsl )info = n + 2_${ik}$
else
if( ip==1_${ik}$ ) then
! last eigenvalue of conjugate pair
cursl = cursl .or. lastsl
lastsl = cursl
if( cursl )sdim = sdim + 2_${ik}$
ip = -1_${ik}$
if( cursl .and. .not.lst2sl )info = n + 2_${ik}$
else
! first eigenvalue of conjugate pair
ip = 1_${ik}$
end if
end if
lst2sl = lastsl
lastsl = cursl
end do
end if
50 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$gges3
#:endif
#:endfor
module subroutine stdlib${ii}$_cgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, &
!! CGGES3 computes for a pair of N-by-N complex nonsymmetric matrices
!! (A,B), the generalized eigenvalues, the generalized complex Schur
!! form (S, T), and optionally left and/or right Schur vectors (VSL
!! and VSR). This gives the generalized Schur factorization
!! (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!! where (VSR)**H is the conjugate-transpose of VSR.
!! Optionally, it also orders the eigenvalues so that a selected cluster
!! of eigenvalues appears in the leading diagonal blocks of the upper
!! triangular matrix S and the upper triangular matrix T. The leading
!! columns of VSL and VSR then form an unitary basis for the
!! corresponding left and right eigenspaces (deflating subspaces).
!! (If only the generalized eigenvalues are needed, use the driver
!! CGGEV instead, which is faster.)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!! or a ratio alpha/beta = w, such that A - w*B is singular. It is
!! usually represented as the pair (alpha,beta), as there is a
!! reasonable interpretation for beta=0, and even for both being zero.
!! A pair of matrices (S,T) is in generalized complex Schur form if S
!! and T are upper triangular and, in addition, the diagonal elements
!! of T are non-negative real numbers.
vsl, ldvsl, vsr, ldvsr,work, lwork, rwork, bwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobvsl, jobvsr, sort
integer(${ik}$), intent(out) :: info, sdim
integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n
! Array Arguments
logical(lk), intent(out) :: bwork(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*)
! Function Arguments
procedure(stdlib_selctg_c) :: selctg
! =====================================================================
! Local Scalars
logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst
integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, &
itau, iwrk, lwkopt
real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum
! Local Arrays
integer(${ik}$) :: idum(1_${ik}$)
real(sp) :: dif(2_${ik}$)
! Intrinsic Functions
! Executable Statements
! decode the input arguments
if( stdlib_lsame( jobvsl, 'N' ) ) then
ijobvl = 1_${ik}$
ilvsl = .false.
else if( stdlib_lsame( jobvsl, 'V' ) ) then
ijobvl = 2_${ik}$
ilvsl = .true.
else
ijobvl = -1_${ik}$
ilvsl = .false.
end if
if( stdlib_lsame( jobvsr, 'N' ) ) then
ijobvr = 1_${ik}$
ilvsr = .false.
else if( stdlib_lsame( jobvsr, 'V' ) ) then
ijobvr = 2_${ik}$
ilvsr = .true.
else
ijobvr = -1_${ik}$
ilvsr = .false.
end if
wantst = stdlib_lsame( sort, 'S' )
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
if( ijobvl<=0_${ik}$ ) then
info = -1_${ik}$
else if( ijobvr<=0_${ik}$ ) then
info = -2_${ik}$
else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( ldvsl<1_${ik}$ .or. ( ilvsl .and. ldvsl<n ) ) then
info = -14_${ik}$
else if( ldvsr<1_${ik}$ .or. ( ilvsr .and. ldvsr<n ) ) then
info = -16_${ik}$
else if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -18_${ik}$
end if
! compute workspace
if( info==0_${ik}$ ) then
call stdlib${ii}$_cgeqrf( n, n, b, ldb, work, work, -1_${ik}$, ierr )
lwkopt = max( 1_${ik}$, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_cunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
if( ilvsl ) then
call stdlib${ii}$_cungqr( n, n, n, vsl, ldvsl, work, work, -1_${ik}$,ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
call stdlib${ii}$_cgghd3( jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, &
work, -1_${ik}$, ierr )
lwkopt = max( lwkopt, n + int( work( 1_${ik}$ ),KIND=${ik}$) )
call stdlib${ii}$_claqz0( 'S', jobvsl, jobvsr, n, 1_${ik}$, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work, -1_${ik}$,rwork, 0_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
if( wantst ) then
call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, sdim,pvsl, pvsr, dif, work, -1_${ik}$, idum, 1_${ik}$, ierr )
lwkopt = max( lwkopt, int( work( 1_${ik}$ ),KIND=${ik}$) )
end if
work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp)
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CGGES3 ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
sdim = 0_${ik}$
return
end if
! get machine constants
eps = stdlib${ii}$_slamch( 'P' )
smlnum = stdlib${ii}$_slamch( 'S' )
bignum = one / smlnum
call stdlib${ii}$_slabad( smlnum, bignum )
smlnum = sqrt( smlnum ) / eps
bignum = one / smlnum
! scale a if max element outside range [smlnum,bignum]
anrm = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork )
ilascl = .false.
if( anrm>zero .and. anrm<smlnum ) then
anrmto = smlnum
ilascl = .true.
else if( anrm>bignum ) then
anrmto = bignum
ilascl = .true.
end if
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, n, a, lda, ierr )
! scale b if max element outside range [smlnum,bignum]
bnrm = stdlib${ii}$_clange( 'M', n, n, b, ldb, rwork )
ilbscl = .false.
if( bnrm>zero .and. bnrm<smlnum ) then
bnrmto = smlnum
ilbscl = .true.
else if( bnrm>bignum ) then
bnrmto = bignum
ilbscl = .true.
end if
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, n, b, ldb, ierr )
! permute the matrix to make it more nearly triangular
ileft = 1_${ik}$
iright = n + 1_${ik}$
irwrk = iright + n
call stdlib${ii}$_cggbal( 'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),rwork( iright ), &
rwork( irwrk ), ierr )
! reduce b to triangular form (qr decomposition of b)
irows = ihi + 1_${ik}$ - ilo
icols = n + 1_${ik}$ - ilo
itau = 1_${ik}$
iwrk = itau + irows
call stdlib${ii}$_cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),work( iwrk ), lwork+&
1_${ik}$-iwrk, ierr )
! apply the orthogonal transformation to matrix a
call stdlib${ii}$_cunmqr( 'L', 'C', irows, icols, irows, b( ilo, ilo ), ldb,work( itau ), a( &
ilo, ilo ), lda, work( iwrk ),lwork+1-iwrk, ierr )
! initialize vsl
if( ilvsl ) then
call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl )
if( irows>1_${ik}$ ) then
call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )&
, ldvsl )
end if
call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( &
iwrk ), lwork+1-iwrk, ierr )
end if
! initialize vsr
if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr )
! reduce to generalized hessenberg form
call stdlib${ii}$_cgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,&
work( iwrk ), lwork+1-iwrk, ierr )
sdim = 0_${ik}$
! perform qz algorithm, computing schur vectors if desired
iwrk = itau
call stdlib${ii}$_claqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, &
ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr )
if( ierr/=0_${ik}$ ) then
if( ierr>0_${ik}$ .and. ierr<=n ) then
info = ierr
else if( ierr>n .and. ierr<=2_${ik}$*n ) then
info = ierr - n
else
info = n + 1_${ik}$
end if
go to 30
end if
! sort eigenvalues alpha/beta if desired
if( wantst ) then
! undo scaling on eigenvalues before selecting
if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr )
if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr )
! select eigenvalues
do i = 1, n
bwork( i ) = selctg( alpha( i ), beta( i ) )
end do
call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, &
ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr )
if( ierr==1_${ik}$ )info = n + 3_${ik}$
end if
! apply back-permutation to vsl and vsr
if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsl, ldvsl, ierr )
if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), &
n, vsr, ldvsr, ierr )
! undo scaling
if( ilascl ) 