vector hermdl(cmatrix& a)
{
char UPLO='U';
char JOBZ='V';
int INFO=0;
int N=a.Rows;
int LDA=N;
int LWORK=2*N;
cvector WORK(LWORK);
vector W(N);
vector RWORK(3*N);
FORTRAN(cheev)(&JOBZ,&UPLO,&N,a.TheMatrix,&LDA,W.TheVector,WORK.TheVector,
&LWORK,RWORK.TheVector,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return W;
}
void GeneralizedEigenSystemSolverRealGeneralMatrices(Array2 < doublevar > & Ain,
Array1 <dcomplex> & W, Array2 <doublevar> & VL, Array2 <doublevar> & VR) {
#ifdef USE_LAPACK //if LAPACK
int N=Ain.dim[0];
Array2 <doublevar> A_temp=Ain; //,VL(N,N),VR(N,N);
Array1 <doublevar> WORK,RWORK(2*N),WI(N),WR(N);
WI.Resize(N);
VL.Resize(N,N);
VR.Resize(N,N);
int info;
int NB=64;
int NMAX=N;
int lda=NMAX;
int ldb=NMAX;
int LWORK=5*NMAX;
WORK.Resize(LWORK);
info= dgeev('V','V',N,A_temp.v, lda,WR.v,WI.v,VL.v,lda,VR.v,lda,WORK.v,LWORK);
if(info>0)
error("Internal error in the LAPACK routine dgeev",info);
if(info<0)
error("Problem with the input parameter of LAPACK routine dgeev in position ",-info);
W.Resize(N);
for(int i=0; i< N; i++) {
W(i)=dcomplex(WR(i),WI(i));
}
// for (int i=0; i<N; i++)
// evals(i)=W[N-1-i];
// for (int i=0; i<N; i++) {
// for (int j=0; j<N; j++) {
// evecs(j,i)=A_temp(N-1-i,j);
// }
// }
//END OF LAPACK
#else //IF NO LAPACK
error("need LAPACK for eigensystem solver for general matrices");
#endif //END OF NO LAPACK
}
cvector diag(cmatrix& a,cmatrix &VL,cmatrix &VR)
// returns eigenvalues in a vector and transforms the matrix argument
{
int N=a.Rows;
char JOBVL='V';
char JOBVR='V';
int INFO=0;
int LDA=N;
int LDVL=N;
int LDVR=N;
int LWORK=2*N;
cvector WORK(LWORK);
cvector W(N);
vector RWORK(2*N);
FORTRAN(zgeev)(&JOBVL,&JOBVR,&N,a.TheMatrix,&LDA,W.TheVector,VL.TheMatrix,&LDVL,
VR.TheMatrix,&LDVR,WORK.TheVector,&LWORK,
RWORK.TheVector,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return W;
}
/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm,
doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *
lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
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 of the LAPACK
Users' Guide.
Arguments
=========
BALANC (input) CHARACTER*1
Indicates how the input matrix should be diagonally scaled
and/or permuted to improve the conditioning of its
eigenvalues.
= 'N': Do not diagonally scale or permute;
= 'P': Perform permutations to make the matrix more nearly
upper triangular. Do not diagonally scale;
= 'S': Diagonally scale the matrix, ie. replace A by
D*A*D**(-1), where D is a diagonal matrix chosen
to make the rows and columns of A more equal in
norm. Do not permute;
= 'B': Both diagonally scale and permute A.
Computed reciprocal condition numbers will be for the matrix
after balancing and/or permuting. Permuting does not change
condition numbers (in exact arithmetic), but balancing does.
JOBVL (input) CHARACTER*1
= 'N': left eigenvectors of A are not computed;
= 'V': left eigenvectors of A are computed.
If SENSE = 'E' or 'B', JOBVL must = 'V'.
JOBVR (input) CHARACTER*1
= 'N': right eigenvectors of A are not computed;
= 'V': right eigenvectors of A are computed.
If SENSE = 'E' or 'B', JOBVR must = 'V'.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': None are computed;
= 'E': Computed for eigenvalues only;
= 'V': Computed for right eigenvectors only;
= 'B': Computed for eigenvalues and right eigenvectors.
If SENSE = 'E' or 'B', both left and right eigenvectors
must also be computed (JOBVL = 'V' and JOBVR = 'V').
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the N-by-N matrix A.
On exit, A has been overwritten. If JOBVL = 'V' or
JOBVR = 'V', A contains the Schur form of the balanced
version of the matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
W contains the computed eigenvalues.
VL (output) COMPLEX*16 array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order
as their eigenvalues.
If JOBVL = 'N', VL is not referenced.
u(j) = VL(:,j), the j-th column of VL.
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= 1; if
JOBVL = 'V', LDVL >= N.
VR (output) COMPLEX*16 array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order
as their eigenvalues.
If JOBVR = 'N', VR is not referenced.
v(j) = VR(:,j), the j-th column of VR.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1; if
JOBVR = 'V', LDVR >= N.
ILO,IHI (output) INTEGER
ILO and IHI are integer values determined when A was
balanced. The balanced A(i,j) = 0 if I > J and
J = 1,...,ILO-1 or I = IHI+1,...,N.
SCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
when balancing A. If P(j) is the index of the row and column
interchanged with row and column j, and D(j) is the scaling
factor applied to row and column j, then
SCALE(J) = P(J), for J = 1,...,ILO-1
= D(J), for J = ILO,...,IHI
= P(J) for J = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
ABNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix (the maximum
of the sum of absolute values of elements of any column).
RCONDE (output) DOUBLE PRECISION array, dimension (N)
RCONDE(j) is the reciprocal condition number of the j-th
eigenvalue.
RCONDV (output) DOUBLE PRECISION array, dimension (N)
RCONDV(j) is the reciprocal condition number of the j-th
right eigenvector.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. If SENSE = 'N' or 'E',
LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
LWORK >= N*N+2*N.
For good performance, LWORK must generally be larger.
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the QR algorithm failed to compute all the
eigenvalues, and no eigenvectors or condition numbers
have been computed; elements 1:ILO-1 and i+1:N of W
contain eigenvalues which have converged.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__4 = 4;
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static char side[1];
static integer maxb;
static doublereal anrm;
static integer ierr, itau, iwrk, nout, i, k, icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static logical scalea;
extern doublereal dlamch_(char *);
static doublereal cscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), zgebak_(char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zgebal_(char *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static logical select[1];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal bignum;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *);
static integer minwrk, maxwrk;
static logical wantvl, wntsnb;
static integer hswork;
static logical wntsne;
static doublereal smlnum;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static logical wantvr;
extern /* Subroutine */ int ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *), ztrsna_(char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *, doublecomplex *, integer *, doublereal *, doublereal
*, integer *, integer *, doublecomplex *, integer *, doublereal *,
integer *), zunghr_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *);
static logical wntsnn, wntsnv;
static char job[1];
static doublereal scl, dum[1], eps;
static doublecomplex tmp;
#define DUM(I) dum[(I)]
#define W(I) w[(I)-1]
#define SCALE(I) scale[(I)-1]
#define RCONDE(I) rconde[(I)-1]
#define RCONDV(I) rcondv[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
*info = 0;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") ||
lsame_(balanc, "P") || lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -12;
}
/* 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 ILAENV.
HSWORK refers to the workspace preferred by ZHSEQR, as
calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
the worst case.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0,
6L, 1L);
if (! wantvl && ! wantvr) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
if (wntsnn) {
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "EN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
} else {
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
}
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,1);
maxwrk = max(i__1,hswork);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
} else {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "EN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,1);
maxwrk = max(i__1,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
" ", n, &c__1, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 1, i__1 = max(i__1,i__2);
maxwrk = max(i__1,1);
}
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
}
if (*lwork < minwrk) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEEVX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = zlange_("M", n, n, &A(1,1), lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &A(1,1), lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
zgebal_(balanc, n, &A(1,1), lda, ilo, ihi, &SCALE(1), &ierr);
*abnrm = zlange_("1", n, n, &A(1,1), lda, dum);
if (scalea) {
DUM(0) = *abnrm;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = DUM(0);
}
/* Reduce to upper Hessenberg form
(CWorkspace: need 2*N, prefer N+N*NB)
(RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
zgehrd_(n, ilo, ihi, &A(1,1), lda, &WORK(itau), &WORK(iwrk), &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors
Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
zlacpy_("L", n, n, &A(1,1), lda, &VL(1,1), ldvl);
/* Generate unitary matrix in VL
(CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
(RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &VL(1,1), ldvl, &WORK(itau), &WORK(iwrk), &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL
(CWorkspace: need 1, prefer HSWORK (see comments) )
(RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &A(1,1), lda, &W(1), &VL(1,1), ldvl, &WORK(iwrk), &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors
Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
zlacpy_("F", n, n, &VL(1,1), ldvl, &VR(1,1), ldvr)
;
}
} else if (wantvr) {
/* Want right eigenvectors
Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
zlacpy_("L", n, n, &A(1,1), lda, &VR(1,1), ldvr);
/* Generate unitary matrix in VR
(CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
(RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &VR(1,1), ldvr, &WORK(itau), &WORK(iwrk), &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR
(CWorkspace: need 1, prefer HSWORK (see comments) )
(RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &A(1,1), lda, &W(1), &VR(1,1), ldvr, &WORK(iwrk), &i__1, info);
} else {
/* Compute eigenvalues only
If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) )
(RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_(job, "N", n, ilo, ihi, &A(1,1), lda, &W(1), &VR(1,1), ldvr, &WORK(iwrk), &i__1, info);
}
/* If INFO > 0 from ZHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors
(CWorkspace: need 2*N)
(RWorkspace: need N) */
ztrevc_(side, "B", select, n, &A(1,1), lda, &VL(1,1), ldvl,
&VR(1,1), ldvr, n, &nout, &WORK(iwrk), &RWORK(1), &
ierr);
}
/* Compute condition numbers if desired
(CWorkspace: need N*N+2*N unless SENSE = 'E')
(RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn) {
ztrsna_(sense, "A", select, n, &A(1,1), lda, &VL(1,1),
ldvl, &VR(1,1), ldvr, &RCONDE(1), &RCONDV(1), n, &nout,
&WORK(iwrk), n, &RWORK(1), &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
zgebak_(balanc, "L", n, ilo, ihi, &SCALE(1), n, &VL(1,1), ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real
*/
i__1 = *n;
for (i = 1; i <= *n; ++i) {
scl = 1. / dznrm2_(n, &VL(1,i), &c__1);
zdscal_(n, &scl, &VL(1,i), &c__1);
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + i * vl_dim1;
/* Computing 2nd power */
d__1 = VL(k,i).r;
/* Computing 2nd power */
d__2 = d_imag(&VL(k,i));
RWORK(k) = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &RWORK(1), &c__1);
d_cnjg(&z__2, &VL(k,i));
d__1 = sqrt(RWORK(k));
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &VL(1,i), &c__1);
i__2 = k + i * vl_dim1;
i__3 = k + i * vl_dim1;
d__1 = VL(k,i).r;
z__1.r = d__1, z__1.i = 0.;
VL(k,i).r = z__1.r, VL(k,i).i = z__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
zgebak_(balanc, "R", n, ilo, ihi, &SCALE(1), n, &VR(1,1), ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real
*/
i__1 = *n;
for (i = 1; i <= *n; ++i) {
scl = 1. / dznrm2_(n, &VR(1,i), &c__1);
zdscal_(n, &scl, &VR(1,i), &c__1);
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + i * vr_dim1;
/* Computing 2nd power */
d__1 = VR(k,i).r;
/* Computing 2nd power */
d__2 = d_imag(&VR(k,i));
RWORK(k) = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &RWORK(1), &c__1);
d_cnjg(&z__2, &VR(k,i));
d__1 = sqrt(RWORK(k));
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &VR(1,i), &c__1);
i__2 = k + i * vr_dim1;
i__3 = k + i * vr_dim1;
d__1 = VR(k,i).r;
z__1.r = d__1, z__1.i = 0.;
VR(k,i).r = z__1.r, VR(k,i).i = z__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &W(*info + 1)
, &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &RCONDV(
1), n, &ierr);
}
} else {
i__1 = *ilo - 1;
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &W(1), n,
&ierr);
}
}
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
return 0;
/* End of ZGEEVX */
} /* zgeevx_ */
/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *w, complex *z, integer *ldz,
complex *work, real *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHBEV computes all the eigenvalues and, optionally, eigenvectors of
a complex Hermitian band matrix A.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, AB is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the first
superdiagonal and the diagonal of the tridiagonal matrix T
are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
the diagonal and first subdiagonal of T are returned in the
first two rows of AB.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD + 1.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (max(1,3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static real c_b11 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static real anrm;
static integer imax;
static real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical lower, wantz;
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *);
static integer iscale;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *,
integer *, real *, real *, complex *, integer *, complex *,
integer *);
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indrwk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
static real smlnum, eps;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = ab_dim1 + 1;
W(1) = AB(1,1).r;
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1.f, Z(1,1).i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhb_("M", uplo, n, kd, &AB(1,1), ldab, &RWORK(1));
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
clascl_("B", kd, kd, &c_b11, &sigma, n, n, &AB(1,1), ldab,
info);
} else {
clascl_("Q", kd, kd, &c_b11, &sigma, n, n, &AB(1,1), ldab,
info);
}
}
/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
chbtrd_(jobz, uplo, n, kd, &AB(1,1), ldab, &W(1), &RWORK(inde), &Z(1,1), ldz, &WORK(1), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR.
*/
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
indrwk = inde + *n;
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
indrwk), info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &W(1), &c__1);
}
return 0;
/* End of CHBEV */
} /* chbev_ */
/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *
nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZPBRFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian positive definite
and banded, and provides error bounds and backward error estimates
for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The upper or lower triangle of the Hermitian band matrix A,
stored in the first KD+1 rows of the array. The j-th column
of A is stored in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
AFB (input) COMPLEX*16 array, dimension (LDAFB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A as computed by
ZPBTRF, in the same storage format as A (see AB).
LDAFB (input) INTEGER
The leading dimension of the array AFB. LDAFB >= KD+1.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by ZPBTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k, l;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal lstres;
extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
integer *);
static doublereal eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define AFB(I,J) afb[(I)-1 + ((J)-1)* ( *ldafb)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldafb < *kd + 1) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1
Computing MIN */
i__1 = *n + 1, i__2 = (*kd << 1) + 2;
nz = min(i__1,i__2);
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
zcopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
z__1.r = -1., z__1.i = 0.;
zhbmv_(uplo, n, kd, &z__1, &AB(1,1), ldab, &X(1,j), &
c__1, &c_b1, &WORK(1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i + j * b_dim1;
RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
l = *kd + 1 - k;
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(l+i,k)), abs(d__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L40: */
}
i__5 = *kd + 1 + k * ab_dim1;
RWORK(k) = RWORK(k) + (d__1 = AB(*kd+1,k).r, abs(d__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
i__5 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
i__5 = k * ab_dim1 + 1;
RWORK(k) += (d__1 = AB(1,k).r, abs(d__1)) * xk;
l = 1 - k;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(l+i,k)), abs(d__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L60: */
}
RWORK(k) += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) +
safe1);
s = max(d__3,d__4);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1), n,
info);
zaxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use ZLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L120: */
}
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 =
d_imag(&X(i,j)), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of ZPBRFS */
} /* zpbrfs_ */
/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d, real *e,
complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,
integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
Using the divide and conquer method, CLAED0 computes all eigenvalues
of a symmetric tridiagonal matrix which is one diagonal block of
those from reducing a dense or band Hermitian matrix and
corresponding eigenvectors of the dense or band matrix.
Arguments
=========
QSIZ (input) INTEGER
The dimension of the unitary matrix used to reduce
the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, the eigenvalues in ascending order.
E (input/output) REAL array, dimension (N-1)
On entry, the off-diagonal elements of the tridiagonal matrix.
On exit, E has been destroyed.
Q (input/output) COMPLEX array, dimension (LDQ,N)
On entry, Q must contain an QSIZ x N matrix whose columns
unitarily orthonormal. It is a part of the unitary matrix
that reduces the full dense Hermitian matrix to a
(reducible) symmetric tridiagonal matrix.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
IWORK (workspace) INTEGER array,
the dimension of IWORK must be at least
6 + 6*N + 5*N*lg N
( lg( N ) = smallest integer k
such that 2^k >= N )
RWORK (workspace) REAL array,
dimension (1 + 3*N + 2*N*lg N + 3*N**2)
( lg( N ) = smallest integer k
such that 2^k >= N )
QSTORE (workspace) COMPLEX array, dimension (LDQS, N)
Used to store parts of
the eigenvector matrix when the updating matrix multiplies
take place.
LDQS (input) INTEGER
The leading dimension of the array QSTORE.
LDQS >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an eigenvalue while
working on the submatrix lying in rows and columns
INFO/(N+1) through mod(INFO,N+1).
=====================================================================
Warning: N could be as big as QSIZ!
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static real temp;
static integer curr, i, j, k, iperm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer indxq, iwrem;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer iqptr;
extern /* Subroutine */ int claed7_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, complex *, integer *,
real *, integer *, real *, integer *, integer *, integer *,
integer *, integer *, real *, complex *, real *, integer *,
integer *);
static integer tlvls, ll, iq;
extern /* Subroutine */ int clacrm_(integer *, integer *, complex *,
integer *, real *, integer *, complex *, integer *, real *);
static integer igivcl;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz,
iprmpt;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
static integer lgn, msd2, smm1, spm1, spm2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define QSTORE(I,J) qstore[(I)-1 + ((J)-1)* ( *ldqs)]
*info = 0;
/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
$ THEN */
if (*qsiz < max(0,*n)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
} else if (*ldqs < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED0", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the size and placement of the submatrices, and save in
the leading elements of IWORK. */
IWORK(1) = *n;
subpbs = 1;
tlvls = 0;
L10:
if (IWORK(subpbs) > 25) {
for (j = subpbs; j >= 1; --j) {
IWORK(j * 2) = (IWORK(j) + 1) / 2;
IWORK((j << 1) - 1) = IWORK(j) / 2;
/* L20: */
}
++tlvls;
subpbs <<= 1;
goto L10;
}
i__1 = subpbs;
for (j = 2; j <= subpbs; ++j) {
IWORK(j) += IWORK(j - 1);
/* L30: */
}
/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
using rank-1 modifications (cuts). */
spm1 = subpbs - 1;
i__1 = spm1;
for (i = 1; i <= spm1; ++i) {
submat = IWORK(i) + 1;
smm1 = submat - 1;
D(smm1) -= (r__1 = E(smm1), dabs(r__1));
D(submat) -= (r__1 = E(smm1), dabs(r__1));
/* L40: */
}
indxq = (*n << 2) + 3;
/* Set up workspaces for eigenvalues only/accumulate new vectors
routine */
temp = log((real) (*n)) / log(2.f);
lgn = (integer) temp;
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
iprmpt = indxq + *n + 1;
iperm = iprmpt + *n * lgn;
iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn;
igivnm = 1;
iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
i__1 = *n;
iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */
i__1 = subpbs;
for (i = 0; i <= subpbs; ++i) {
IWORK(iprmpt + i) = 1;
IWORK(igivpt + i) = 1;
/* L50: */
}
IWORK(iqptr) = 1;
/* Solve each submatrix eigenproblem at the bottom of the divide and
conquer tree. */
curr = 0;
i__1 = spm1;
for (i = 0; i <= spm1; ++i) {
if (i == 0) {
submat = 1;
matsiz = IWORK(1);
} else {
submat = IWORK(i) + 1;
matsiz = IWORK(i + 1) - IWORK(i);
}
ll = iq - 1 + IWORK(iqptr + curr);
ssteqr_("I", &matsiz, &D(submat), &E(submat), &RWORK(ll), &matsiz, &
RWORK(1), info);
clacrm_(qsiz, &matsiz, &Q(1,submat), ldq, &RWORK(ll), &
matsiz, &QSTORE(1,submat), ldqs, &RWORK(iwrem)
);
/* Computing 2nd power */
i__2 = matsiz;
IWORK(iqptr + curr + 1) = IWORK(iqptr + curr) + i__2 * i__2;
++curr;
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
k = 1;
i__2 = IWORK(i + 1);
for (j = submat; j <= IWORK(i+1); ++j) {
IWORK(indxq + j) = k;
++k;
/* L60: */
}
/* L70: */
}
/* Successively merge eigensystems of adjacent submatrices
into eigensystem for the corresponding larger matrix.
while ( SUBPBS > 1 ) */
curlvl = 1;
L80:
if (subpbs > 1) {
spm2 = subpbs - 2;
i__1 = spm2;
for (i = 0; i <= spm2; i += 2) {
if (i == 0) {
submat = 1;
matsiz = IWORK(2);
msd2 = IWORK(1);
curprb = 0;
} else {
submat = IWORK(i) + 1;
matsiz = IWORK(i + 2) - IWORK(i);
msd2 = matsiz / 2;
++curprb;
}
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - M
SD2)
into an eigensystem of size MATSIZ. CLAED7 handles the cas
e
when the eigenvectors of a full or band Hermitian matrix (w
hich
was reduced to tridiagonal form) are desired.
I am free to use Q as a valuable working space until Loop 1
50. */
claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &D(submat)
, &QSTORE(1,submat), ldqs, &E(submat +
msd2 - 1), &IWORK(indxq + submat), &RWORK(iq), &IWORK(
iqptr), &IWORK(iprmpt), &IWORK(iperm), &IWORK(igivpt), &
IWORK(igivcl), &RWORK(igivnm), &Q(1,submat), &
RWORK(iwrem), &IWORK(subpbs + 1), info);
if (*info > 0) {
*info = submat * (*n + 1) + submat + matsiz - 1;
return 0;
}
IWORK(i / 2 + 1) = IWORK(i + 2);
/* L90: */
}
subpbs /= 2;
++curlvl;
goto L80;
}
/* end while
Re-merge the eigenvalues/vectors which were deflated at the final
merge step. */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
j = IWORK(indxq + i);
RWORK(i) = D(j);
ccopy_(qsiz, &QSTORE(1,j), &c__1, &Q(1,i),
&c__1);
/* L100: */
}
scopy_(n, &RWORK(1), &c__1, &D(1), &c__1);
return 0;
/* End of CLAED0 */
} /* claed0_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
complex *h, integer *ldh, complex *w, complex *v, complex *b, integer
*ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
doublereal d__1;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#define V(I) v[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define H(I,J) h[(I)-1 + ((J)-1)* ( *ldh)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__3 = i + j * b_dim1;
i__4 = i + j * h_dim1;
B(i,j).r = H(i,j).r, B(i,j).i = H(i,j).i;
/* L10: */
}
i__2 = j + j * b_dim1;
i__3 = j + j * h_dim1;
q__1.r = H(j,j).r - w->r, q__1.i = H(j,j).i - w->i;
B(j,j).r = q__1.r, B(j,j).i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
i__2 = i;
V(i).r = *eps3, V(i).i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &V(1), &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &V(1), &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
i__2 = i + 1 + i * h_dim1;
ei.r = H(i+1,i).r, ei.i = H(i+1,i).i;
i__2 = i + i * b_dim1;
if ((r__1 = B(i,i).r, dabs(r__1)) + (r__2 = r_imag(&B(i,i)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4
= r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &B(i,i), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = i + i * b_dim1;
B(i,i).r = ei.r, B(i,i).i = ei.i;
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
i__3 = i + 1 + j * b_dim1;
temp.r = B(i+1,j).r, temp.i = B(i+1,j).i;
i__3 = i + 1 + j * b_dim1;
i__4 = i + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = B(i,j).r - q__2.r, q__1.i = B(i,j).i - q__2.i;
B(i+1,j).r = q__1.r, B(i+1,j).i = q__1.i;
i__3 = i + j * b_dim1;
B(i,j).r = temp.r, B(i,j).i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = i + i * b_dim1;
if (B(i,i).r == 0.f && B(i,i).i == 0.f) {
i__3 = i + i * b_dim1;
B(i,i).r = *eps3, B(i,i).i = 0.f;
}
cladiv_(&q__1, &ei, &B(i,i));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
i__3 = i + 1 + j * b_dim1;
i__4 = i + 1 + j * b_dim1;
i__5 = i + j * b_dim1;
q__2.r = x.r * B(i,j).r - x.i * B(i,j).i, q__2.i =
x.r * B(i,j).i + x.i * B(i,j).r;
q__1.r = B(i+1,j).r - q__2.r, q__1.i = B(i+1,j).i -
q__2.i;
B(i+1,j).r = q__1.r, B(i+1,j).i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = *n + *n * b_dim1;
if (B(*n,*n).r == 0.f && B(*n,*n).i == 0.f) {
i__2 = *n + *n * b_dim1;
B(*n,*n).r = *eps3, B(*n,*n).i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = j + (j - 1) * h_dim1;
ej.r = H(j,j-1).r, ej.i = H(j,j-1).i;
i__1 = j + j * b_dim1;
if ((r__1 = B(j,j).r, dabs(r__1)) + (r__2 = r_imag(&B(j,j)), dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4
= r_imag(&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &B(j,j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = j + j * b_dim1;
B(j,j).r = ej.r, B(j,j).i = ej.i;
i__1 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__2 = i + (j - 1) * b_dim1;
temp.r = B(i,j-1).r, temp.i = B(i,j-1).i;
i__2 = i + (j - 1) * b_dim1;
i__3 = i + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = B(i,j).r - q__2.r, q__1.i = B(i,j).i - q__2.i;
B(i,j-1).r = q__1.r, B(i,j-1).i = q__1.i;
i__2 = i + j * b_dim1;
B(i,j).r = temp.r, B(i,j).i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = j + j * b_dim1;
if (B(j,j).r == 0.f && B(j,j).i == 0.f) {
i__2 = j + j * b_dim1;
B(j,j).r = *eps3, B(j,j).i = 0.f;
}
cladiv_(&q__1, &ej, &B(j,j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__2 = i + (j - 1) * b_dim1;
i__3 = i + (j - 1) * b_dim1;
i__4 = i + j * b_dim1;
q__2.r = x.r * B(i,j).r - x.i * B(i,j).i, q__2.i =
x.r * B(i,j).i + x.i * B(i,j).r;
q__1.r = B(i,j-1).r - q__2.r, q__1.i = B(i,j-1).i -
q__2.i;
B(i,j-1).r = q__1.r, B(i,j-1).i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_dim1 + 1;
if (B(1,1).r == 0.f && B(1,1).i == 0.f) {
i__2 = b_dim1 + 1;
B(1,1).r = *eps3, B(1,1).i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= *n; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &B(1,1), ldb, &V(1)
, &scale, &RWORK(1), &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &V(1), &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
V(1).r = *eps3, V(1).i = 0.f;
i__2 = *n;
for (i = 2; i <= *n; ++i) {
i__3 = i;
V(i).r = rtemp, V(i).i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
d__1 = *eps3 * rootn;
q__1.r = V(*n-its+1).r - d__1, q__1.i = V(*n-its+1).i;
V(*n-its+1).r = q__1.r, V(*n-its+1).i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i = icamax_(n, &V(1), &c__1);
i__1 = i;
r__3 = 1.f / ((r__1 = V(i).r, dabs(r__1)) + (r__2 = r_imag(&V(i)),
dabs(r__2)));
csscal_(n, &r__3, &V(1), &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap,
doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal
*rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZPPCON estimates the reciprocal of the condition number (in the
1-norm) of a complex Hermitian positive definite packed matrix using
the Cholesky factorization A = U**H*U or A = L*L**H computed by
ZPPTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H, packed columnwise in a linear
array. The j-th column of U or L is stored in the array AP
as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
ANORM (input) DOUBLE PRECISION
The 1-norm (or infinity-norm) of the Hermitian matrix A.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal scale;
extern logical lsame_(char *, char *);
static logical upper;
extern doublereal dlamch_(char *);
static integer ix;
static doublereal scalel, scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
static doublereal smlnum;
extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
integer *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, integer *);
#define RWORK(I) rwork[(I)-1]
#define WORK(I) work[(I)-1]
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
zlatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
AP(1), &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
zlatps_("Upper", "No transpose", "Non-unit", normin, n, &AP(1), &
WORK(1), &scaleu, &RWORK(1), info);
} else {
/* Multiply by inv(L). */
zlatps_("Lower", "No transpose", "Non-unit", normin, n, &AP(1), &
WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
zlatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
AP(1), &WORK(1), &scaleu, &RWORK(1), info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of ZPPCON */
} /* zppcon_ */
/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
real *w, complex *z, integer *ldz, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix in packed storage.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))
RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static real anrm;
static integer imax;
static real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical wantz;
static integer iscale;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
static real smlnum, eps;
#define AP(I) ap[(I)-1]
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
W(1) = AP(1).r;
RWORK(1) = 1.f;
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1.f, Z(1,1).i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhp_("M", uplo, n, &AP(1), &RWORK(1));
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &AP(1), &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*/
inde = 1;
indtau = 1;
chptrd_(uplo, n, &AP(1), &W(1), &RWORK(inde), &WORK(indtau), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call
CUPGTR to generate the orthogonal matrix, then call CSTEQR. */
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
indwrk = indtau + *n;
cupgtr_(uplo, n, &AP(1), &WORK(indtau), &Z(1,1), ldz, &WORK(
indwrk), &iinfo);
indrwk = inde + *n;
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
indrwk), info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &W(1), &c__1);
}
return 0;
/* End of CHPEV */
} /* chpev_ */
/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTBCON estimates the reciprocal of the condition number of a
triangular band matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer ix;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
static logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
static char normin[1];
static doublereal smlnum;
static logical nounit;
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = zlantb_(norm, uplo, diag, n, kd, &AB(1,1), ldab, &RWORK(1));
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatbs_(uplo, "No transpose", diag, normin, n, kd, &AB(1,1), ldab, &WORK(1), &scale, &RWORK(1), info);
} else {
/* Multiply by inv(A'). */
zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &AB(1,1), ldab, &WORK(1), &scale, &RWORK(1), info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overfl
ow. */
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
xnorm = (d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTBCON */
} /* ztbcon_ */
/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHERFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian indefinite, and
provides error bounds and backward error estimates for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) COMPLEX array, dimension (LDAF,N)
The factored form of the matrix A. AF contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**H or
A = L*D*L**H as computed by CHETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) COMPLEX array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CHETRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, complex *, integer *
), ccopy_(integer *, complex *, integer *, complex *,
integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), chetrs_(
char *, integer *, integer *, complex *, integer *, integer *,
complex *, integer *, integer *);
static real lstres, eps;
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.f;
BERR(j) = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
ccopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, n, &q__1, &A(1,1), lda, &X(1,j), &c__1, &
c_b1, &WORK(1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i + j * b_dim1;
RWORK(i) = (r__1 = B(i,j).r, dabs(r__1)) + (r__2 = r_imag(&B(i,j)), dabs(r__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
i__4 = i + k * a_dim1;
RWORK(i) += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 =
r_imag(&A(i,k)), dabs(r__2))) * xk;
i__4 = i + k * a_dim1;
i__5 = i + j * x_dim1;
s += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = r_imag(&A(i,k)), dabs(r__2))) * ((r__3 = X(i,j)
.r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L40: */
}
i__3 = k + k * a_dim1;
RWORK(k) = RWORK(k) + (r__1 = A(k,k).r, dabs(r__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
i__3 = k + k * a_dim1;
RWORK(k) += (r__1 = A(k,k).r, dabs(r__1)) * xk;
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
i__4 = i + k * a_dim1;
RWORK(i) += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 =
r_imag(&A(i,k)), dabs(r__2))) * xk;
i__4 = i + k * a_dim1;
i__5 = i + j * x_dim1;
s += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = r_imag(&A(i,k)), dabs(r__2))) * ((r__3 = X(i,j)
.r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L60: */
}
RWORK(k) += s;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__3 = i;
r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 =
r_imag(&WORK(i)), dabs(r__2))) / RWORK(i);
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i;
r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 =
r_imag(&WORK(i)), dabs(r__2)) + safe1) / (RWORK(i) +
safe1);
s = dmax(r__3,r__4);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(1),
n, info);
caxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
i__3 = i;
RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i);
} else {
i__3 = i;
RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
1), n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i;
i__4 = i;
i__5 = i;
q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i;
i__4 = i;
i__5 = i;
q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L120: */
}
chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
1), n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__3 = i + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = X(i,j).r, dabs(r__1)) + (r__2 =
r_imag(&X(i,j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of CHERFS */
} /* cherfs_ */
/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZSYSVX uses the diagonal pivoting factorization to compute the
solution to a complex system of linear equations A * X = B,
where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the diagonal pivoting method is used to factor A.
The form of the factorization is
A = U * D * U**T, if UPLO = 'U', or
A = L * D * L**T, if UPLO = 'L',
where U (or L) is a product of permutation and unit upper (lower)
triangular matrices, and D is symmetric and block diagonal with
1-by-1 and 2-by-2 diagonal blocks.
2. The factored form of A is used to estimate the condition number
of the matrix A. If the reciprocal of the condition number is
less than machine precision, steps 3 and 4 are skipped.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': On entry, AF and IPIV contain the factored form
of A. A, AF and IPIV will not be modified.
= 'N': The matrix A will be copied to AF and factored.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The symmetric matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
If FACT = 'F', then AF is an input argument and on entry
contains the block diagonal matrix D and the multipliers used
to obtain the factor U or L from the factorization
A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.
If FACT = 'N', then AF is an output argument and on exit
returns the block diagonal matrix D and the multipliers used
to obtain the factor U or L from the factorization
A = U*D*U**T or A = L*D*L**T.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains details of the interchanges and the block structure
of D, as determined by ZSYTRF.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
If FACT = 'N', then IPIV is an output argument and on exit
contains details of the interchanges and the block structure
of D, as determined by ZSYTRF.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) COMPLEX*16 array, dimension (LDX,NRHS)
If INFO = 0, the N-by-NRHS solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) DOUBLE PRECISION
The estimate of the reciprocal condition number of the matrix
A. If RCOND is less than the machine precision (in
particular, if RCOND = 0), the matrix is singular to working
precision. This condition is indicated by a return code of
INFO > 0, and the solution and error bounds are not computed.
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of WORK. LWORK >= 2*N, and for best performance
LWORK >= N*NB, where NB is the optimal blocksize for
ZSYTRF.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: D(i,i) is exactly zero. The factorization
has been completed, but the block diagonal
matrix D is exactly singular, so the solution and
error bounds could not be computed.
= N+1: the block diagonal matrix D is nonsingular, but
RCOND is less than machine precision. The
factorization has been completed, but the matrix
is singular to working precision, so the solution
and error bounds have not been computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
static doublereal anorm;
extern doublereal dlamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacpy_(
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zsyrfs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zsytrf_(char *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *);
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
} else if (*lwork < *n << 1) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
zlacpy_(uplo, n, n, &A(1,1), lda, &AF(1,1), ldaf);
zsytrf_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &WORK(1), lwork,
info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = zlansy_("I", uplo, n, &A(1,1), lda, &RWORK(1));
/* Compute the reciprocal of the condition number of A. */
zsycon_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &anorm, rcond, &WORK(1),
info);
/* Return if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
return 0;
}
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
zsytrs_(uplo, n, nrhs, &AF(1,1), ldaf, &IPIV(1), &X(1,1), ldx,
info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
zsyrfs_(uplo, n, nrhs, &A(1,1), lda, &AF(1,1), ldaf, &IPIV(1),
&B(1,1), ldb, &X(1,1), ldx, &FERR(1), &BERR(1), &WORK(1)
, &RWORK(1), info);
return 0;
/* End of ZSYSVX */
} /* zsysvx_ */
/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl,
integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *
work, integer *lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGEGS computes for a pair of N-by-N complex nonsymmetric matrices A,
B: the generalized eigenvalues (alpha, beta), the complex Schur
form (A, B), and optionally left and/or right Schur vectors
(VSL and VSR).
(If only the generalized eigenvalues are needed, use the driver ZGEGV
instead.)
A generalized eigenvalue for a pair of matrices (A,B) is, roughly
speaking, 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 good beginning reference is the book, "VISMatrix
Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
The (generalized) Schur form of a pair of matrices is the result of
multiplying both matrices on the left by one unitary matrix and
both on the right by another unitary matrix, these two unitary
matrices being chosen so as to bring the pair of matrices into
upper triangular form with the diagonal elements of B being
non-negative real numbers (this is also called complex Schur form.)
The left and right Schur vectors are the columns of VSL and VSR,
respectively, where VSL and VSR are the unitary matrices
which reduce A and B to Schur form:
Schur form of (A,B) = ( (VSL)**H A (VSR), (VSL)**H B (VSR) )
Arguments
=========
JOBVSL (input) CHARACTER*1
= 'N': do not compute the left Schur vectors;
= 'V': compute the left Schur vectors.
JOBVSR (input) CHARACTER*1
= 'N': do not compute the right Schur vectors;
= 'V': compute the right Schur vectors.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the first of the pair of matrices whose generalized
eigenvalues and (optionally) Schur vectors are to be
computed.
On exit, the generalized Schur form of A.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the second of the pair of matrices whose
generalized eigenvalues and (optionally) Schur vectors are
to be computed.
On exit, the generalized Schur form of B.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHA (output) COMPLEX*16 array, dimension (N)
BETA (output) COMPLEX*16 array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),
j=1,...,N are the diagonals of the complex Schur form (A,B)
output by ZGEGS. The BETA(j) will be non-negative real.
Note: the quotients ALPHA(j)/BETA(j) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio alpha/beta.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VSL (output) COMPLEX*16 array, dimension (LDVSL,N)
If JOBVSL = 'V', VSL will contain the left Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSL = 'N'.
LDVSL (input) INTEGER
The leading dimension of the matrix VSL. LDVSL >= 1, and
if JOBVSL = 'V', LDVSL >= N.
VSR (output) COMPLEX*16 array, dimension (LDVSR,N)
If JOBVSR = 'V', VSR will contain the right Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSR = 'N'.
LDVSR (input) INTEGER
The leading dimension of the matrix VSR. LDVSR >= 1, and
if JOBVSR = 'V', LDVSR >= N.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,2*N).
For good performance, LWORK must generally be larger.
To compute the optimal value of LWORK, call ILAENV to get
blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute:
NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;
the optimal LWORK is N*(NB+1).
RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=1,...,N:
The QZ iteration failed. (A,B) are not in Schur
form, but ALPHA(j) and BETA(j) should be correct for
j=INFO+1,...,N.
> N: errors that usually indicate LAPACK problems:
=N+1: error return from ZGGBAL
=N+2: error return from ZGEQRF
=N+3: error return from ZUNMQR
=N+4: error return from ZUNGQR
=N+5: error return from ZGGHRD
=N+6: error return from ZHGEQZ (other than failed
iteration)
=N+7: error return from ZGGBAK (computing VSL)
=N+8: error return from ZGGBAK (computing VSR)
=N+9: error return from ZLASCL (various places)
=====================================================================
Decode the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c_n1 = -1;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2, i__3;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau;
extern logical lsame_(char *, char *);
static integer ileft, iinfo, icols;
static logical ilvsl;
static integer iwork;
static logical ilvsr;
static integer irows;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
static logical ilascl, ilbscl;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal bignum;
static integer ijobvl, iright;
extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
), zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *);
static integer ijobvr;
extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
);
static doublereal anrmto;
static integer lwkmin;
static doublereal bnrmto;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zhgeqz_(
char *, char *, char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static doublereal smlnum;
static integer irwork, lwkopt;
extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zunmqr_(char *, char *, integer *, integer
*, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer ihi, ilo;
static doublereal eps;
#define ALPHA(I) alpha[(I)-1]
#define BETA(I) beta[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VSL(I,J) vsl[(I)-1 + ((J)-1)* ( *ldvsl)]
#define VSR(I,J) vsr[(I)-1 + ((J)-1)* ( *ldvsr)]
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments
Computing MAX */
i__1 = *n << 1;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -11;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -13;
} else if (*lwork < lwkmin) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEGS ", &i__1);
return 0;
}
/* Quick return if possible */
WORK(1).r = (doublereal) lwkopt, WORK(1).i = 0.;
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
smlnum = *n * safmin / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", n, n, &A(1,1), lda, &RWORK(1));
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
zlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &A(1,1), lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = zlange_("M", n, n, &B(1,1), ldb, &RWORK(1));
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
zlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &B(1,1), ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
ileft = 1;
iright = *n + 1;
irwork = iright + *n;
iwork = 1;
zggbal_("P", n, &A(1,1), lda, &B(1,1), ldb, &ilo, &ihi, &RWORK(
ileft), &RWORK(iright), &RWORK(irwork), &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
zgeqrf_(&irows, &icols, &B(ilo,ilo), ldb, &WORK(itau), &WORK(
iwork), &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
zunmqr_("L", "C", &irows, &icols, &irows, &B(ilo,ilo), ldb, &
WORK(itau), &A(ilo,ilo), lda, &WORK(iwork), &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
zlaset_("Full", n, n, &c_b1, &c_b2, &VSL(1,1), ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
zlacpy_("L", &i__1, &i__2, &B(ilo+1,ilo), ldb, &VSL(ilo+1,ilo), ldvsl);
i__1 = *lwork + 1 - iwork;
zungqr_(&irows, &irows, &irows, &VSL(ilo,ilo), ldvsl, &
WORK(itau), &WORK(iwork), &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
zlaset_("Full", n, n, &c_b1, &c_b2, &VSR(1,1), ldvsr);
}
/* Reduce to generalized Hessenberg form */
zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1),
ldb, &VSL(1,1), ldvsl, &VSR(1,1), ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
iwork = itau;
i__1 = *lwork + 1 - iwork;
zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1), ldb, &ALPHA(1), &BETA(1), &VSL(1,1), ldvsl, &
VSR(1,1), ldvsr, &WORK(iwork), &i__1, &RWORK(irwork), &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
zggbak_("P", "L", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
VSL(1,1), ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
zggbak_("P", "R", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
VSR(1,1), ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
zlascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &A(1,1), lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
zlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &ALPHA(1), n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
zlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &B(1,1), ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
zlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &BETA(1), n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
WORK(1).r = (doublereal) lwkopt, WORK(1).i = 0.;
return 0;
/* End of ZGEGS */
} /* zgegs_ */
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
doublereal *sep, integer *mm, integer *m, doublecomplex *work,
integer *ldwork, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a complex upper triangular
matrix T (or of any matrix Q*T*Q**H with Q unitary).
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (SEP):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (SEP);
= 'B': for both eigenvalues and eigenvectors (S and SEP).
HOWMNY (input) CHARACTER*1
= 'A': compute condition numbers for all eigenpairs;
= 'S': compute condition numbers for selected eigenpairs
specified by the array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenpairs for which
condition numbers are required. To select condition numbers
for the j-th eigenpair, SELECT(j) must be set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) COMPLEX*16 array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
VR (input) COMPLEX*16 array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
S (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'E' or 'B', the reciprocal condition numbers of the
selected eigenvalues, stored in consecutive elements of the
array. Thus S(j), SEP(j), and the j-th columns of VL and VR
all correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If JOB = 'V', S is not referenced.
SEP (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array.
If JOB = 'E', SEP is not referenced.
MM (input) INTEGER
The number of elements in the arrays S (if JOB = 'E' or 'B')
and/or SEP (if JOB = 'V' or 'B'). MM >= M.
M (output) INTEGER
The number of elements of the arrays S and/or SEP actually
used to store the estimated condition numbers.
If HOWMNY = 'A', M is set to N.
WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)
If JOB = 'E', WORK is not referenced.
LDWORK (input) INTEGER
The leading dimension of the array WORK.
LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
If JOB = 'E', RWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of an eigenvalue lambda is
defined as
S(lambda) = |v'*u| / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of T corresponding
to lambda; v' denotes the conjugate transpose of v, and norm(u)
denotes the Euclidean norm. These reciprocal condition numbers always
lie between zero (very badly conditioned) and one (very well
conditioned). If n = 1, S(lambda) is defined to be 1.
An approximate error bound for a computed eigenvalue W(i) is given by
EPS * norm(T) / S(i)
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
corresponding to lambda is defined as follows. Suppose
T = ( lambda c )
( 0 T22 )
Then the reciprocal condition number is
SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
where sigma-min denotes the smallest singular value. We approximate
the smallest singular value by the reciprocal of an estimate of the
one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
defined to be abs(T(1,1)).
An approximate error bound for a computed right eigenvector VR(i)
is given by
EPS * norm(T) / SEP(i)
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static integer kase, ierr;
static doublecomplex prod;
static doublereal lnrm, rnrm;
static integer i, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublecomplex dummy[1];
static logical wants;
static doublereal xnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
static integer ks, ix;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical somcon;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical wantsp;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static doublereal eps, est;
#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are
to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (SELECT(j)) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! SELECT(1)) {
return 0;
}
}
if (wants) {
S(1) = 1.;
}
if (wantsp) {
SEP(1) = z_abs(&T(1,1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
if (somcon) {
if (! SELECT(k)) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
zdotc_(&z__1, n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
prod.r = z__1.r, prod.i = z__1.i;
rnrm = dznrm2_(n, &VR(1,ks), &c__1);
lnrm = dznrm2_(n, &VL(1,ks), &c__1);
S(ks) = z_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the k-th
diagonal element to the (1,1) position. */
zlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1),
ldwork);
ztrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i = 2; i <= *n; ++i) {
i__3 = i + i * work_dim1;
i__4 = i + i * work_dim1;
i__5 = work_dim1 + 1;
z__1.r = WORK(i,i).r - WORK(1,1).r, z__1.i = WORK(i,i).i -
WORK(1,1).i;
WORK(i,i).r = z__1.r, WORK(i,i).i = z__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The
1st
and (N+1)th columns of WORK are used to store work ve
ctors. */
SEP(ks) = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacon_(&i__2, &WORK(1,*n+1), &WORK(1,1)
, &est, &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &WORK(2,2), ldwork, &
WORK(1,1), &scale, &RWORK(1), &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&WORK(2,2), ldwork, &WORK(1,1), &scale, &RWORK(1), &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
/* Multiply by 1/SCALE if doing so will no
t cause
overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &WORK(1,1), &c__1);
i__2 = ix + work_dim1;
xnorm = (d__1 = WORK(ix,1).r, abs(d__1)) + (d__2 = d_imag(
&WORK(ix,1)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &WORK(1,1), &c__1);
}
goto L30;
}
SEP(ks) = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
} /* ztrsna_ */
/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTBRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular band
coefficient matrix.
The solution matrix X must be computed by ZTBTRS or some other
means before entering this routine. ZTBRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ztbsv_(char *, char *,
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static doublereal lstres, eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *kd + 2;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &X(1,j), &c__1, &WORK(1), &c__1);
ztbmv_(uplo, trans, diag, n, kd, &AB(1,1), ldab, &WORK(1), &
c__1);
z__1.r = -1., z__1.i = 0.;
zaxpy_(n, &z__1, &B(1,j), &c__1, &WORK(1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i + j * b_dim1;
RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__5 = 1, i__3 = k - *kd;
i__4 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__5 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L50: */
}
RWORK(k) += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L90: */
}
RWORK(k) += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MAX */
i__4 = 1, i__5 = k - *kd;
i__3 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__4 = *kd + 1 + i - k + k * ab_dim1;
i__5 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L110: */
}
RWORK(k) += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L130: */
}
RWORK(k) += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L150: */
}
RWORK(k) += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L170: */
}
RWORK(k) += s;
/* L180: */
}
}
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) +
safe1);
s = max(d__3,d__4);
}
/* L190: */
}
BERR(j) = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use ZLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
}
/* L200: */
}
kase = 0;
L210:
zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ztbsv_(uplo, transt, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L230: */
}
ztbsv_(uplo, transn, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 =
d_imag(&X(i,j)), abs(d__2));
lstres = max(d__3,d__4);
/* L240: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L250: */
}
return 0;
/* End of ZTBRFS */
} /* ztbrfs_ */
/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublereal *b, integer *ldb, doublecomplex *c, integer *
ldc, doublereal *rwork)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLACRM performs a very simple matrix-matrix multiplication:
C := A * B,
where A is M by N and complex; B is N by N and real;
C is M by N and complex.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A and of the matrix C.
M >= 0.
N (input) INTEGER
The number of columns and rows of the matrix B and
the number of columns of the matrix C.
N >= 0.
A (input) COMPLEX*16 array, dimension (LDA, N)
A contains the M by N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >=max(1,M).
B (input) DOUBLE PRECISION array, dimension (LDB, N)
B contains the N by N matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >=max(1,N).
C (input) COMPLEX*16 array, dimension (LDC, N)
C contains the M by N matrix C.
LDC (input) INTEGER
The leading dimension of the array C. LDC >=max(1,N).
RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)
=====================================================================
Quick return if possible.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublereal c_b6 = 1.;
static doublereal c_b7 = 0.;
/* System generated locals */
integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i, j, l;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
i__3 = i + j * a_dim1;
RWORK((j - 1) * *m + i) = A(i,j).r;
/* L10: */
}
/* L20: */
}
l = *m * *n + 1;
dgemm_("N", "N", m, n, n, &c_b6, &RWORK(1), m, &B(1,1), ldb, &c_b7, &
RWORK(l), m);
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
i__3 = i + j * c_dim1;
i__4 = l + (j - 1) * *m + i - 1;
C(i,j).r = RWORK(l+(j-1)**m+i-1), C(i,j).i = 0.;
/* L30: */
}
/* L40: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
RWORK((j - 1) * *m + i) = d_imag(&A(i,j));
/* L50: */
}
/* L60: */
}
dgemm_("N", "N", m, n, n, &c_b6, &RWORK(1), m, &B(1,1), ldb, &c_b7, &
RWORK(l), m);
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
i__3 = i + j * c_dim1;
i__4 = i + j * c_dim1;
d__1 = C(i,j).r;
i__5 = l + (j - 1) * *m + i - 1;
z__1.r = d__1, z__1.i = RWORK(l+(j-1)**m+i-1);
C(i,j).r = z__1.r, C(i,j).i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLACRM */
} /* zlacrm_ */
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer
*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTGEVC computes some or all of the right and/or left generalized
eigenvectors of a pair of complex upper triangular matrices (A,B).
The right generalized eigenvector x and the left generalized
eigenvector y of (A,B) corresponding to a generalized eigenvalue
w are defined by:
(A - wB) * x = 0 and y**H * (A - wB) = 0
where y**H denotes the conjugate tranpose of y.
If an eigenvalue w is determined by zero diagonal elements of both A
and B, a unit vector is returned as the corresponding eigenvector.
If all eigenvectors are requested, the routine may either return
the matrices X and/or Y of right or left eigenvectors of (A,B), or
the products Z*X and/or Q*Y, where Z and Q are input unitary
matrices. If (A,B) was obtained from the generalized Schur
factorization of an original pair of matrices
(A0,B0) = (Q*A*Z**H,Q*B*Z**H),
then Z*X and Q*Y are the matrices of right or left eigenvectors of
A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors, and
backtransform them using the input matrices supplied
in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY='S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY='A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of array A. LDA >= max(1,N).
B (input) COMPLEX*16 array, dimension (LDB,N)
The upper triangular matrix B. B must have real diagonal
elements.
LDB (input) INTEGER
The leading dimension of array B. LDB >= max(1,N).
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q
of left Schur vectors returned by ZHGEQZ).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
SELECT, stored consecutively in the columns of
VL, in the same order as their eigenvalues.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Z
of right Schur vectors returned by ZHGEQZ).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Z*X;
if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
SELECT, stored consecutively in the columns of
VR, in the same order as their eigenvalues.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one column.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Decode and Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static integer ibeg, ieig, iend;
static doublereal dmin__;
static integer isrc;
static doublereal temp;
static doublecomplex suma, sumb;
static doublereal xmax;
static doublecomplex d;
static integer i, j;
static doublereal scale;
static logical ilall;
static integer iside;
static doublereal sbeta;
extern logical lsame_(char *, char *);
static doublereal small;
static logical compl;
static doublereal anorm, bnorm;
static logical compr;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublecomplex ca, cb;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static logical ilbbad;
static doublereal acoefa;
static integer je;
static doublereal bcoefa, acoeff;
static doublecomplex bcoeff;
static logical ilback;
static integer im;
static doublereal ascale, bscale;
extern doublereal dlamch_(char *);
static integer jr;
static doublecomplex salpha;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical ilcomp;
static integer ihwmny;
static doublereal big;
static logical lsa, lsb;
static doublereal ulp;
static doublecomplex sum;
#define SELECT(I) select[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
if (lsame_(howmny, "A")) {
ihwmny = 1;
ilall = TRUE_;
ilback = FALSE_;
} else if (lsame_(howmny, "S")) {
ihwmny = 2;
ilall = FALSE_;
ilback = FALSE_;
} else if (lsame_(howmny, "B") || lsame_(howmny, "T")) {
ihwmny = 3;
ilall = TRUE_;
ilback = TRUE_;
} else {
ihwmny = -1;
}
if (lsame_(side, "R")) {
iside = 1;
compl = FALSE_;
compr = TRUE_;
} else if (lsame_(side, "L")) {
iside = 2;
compl = TRUE_;
compr = FALSE_;
} else if (lsame_(side, "B")) {
iside = 3;
compl = TRUE_;
compr = TRUE_;
} else {
iside = -1;
}
/* Count the number of eigenvectors */
if (! ilall) {
im = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (SELECT(j)) {
++im;
}
/* L10: */
}
} else {
im = *n;
}
/* Check diagonal of B */
ilbbad = FALSE_;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (d_imag(&B(j,j)) != 0.) {
ilbbad = TRUE_;
}
/* L20: */
}
*info = 0;
if (iside < 0) {
*info = -1;
} else if (ihwmny < 0) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (ilbbad) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (compl && *ldvl < *n || *ldvl < 1) {
*info = -10;
} else if (compr && *ldvr < *n || *ldvr < 1) {
*info = -12;
} else if (*mm < im) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = dlamch_("Safe minimum");
big = 1. / safmin;
dlabad_(&safmin, &big);
ulp = dlamch_("Epsilon") * dlamch_("Base");
small = safmin * *n / ulp;
big = 1. / small;
bignum = 1. / (safmin * *n);
/* Compute the 1-norm of each column of the strictly upper triangular
part of A and B to check for possible overflow in the triangular
solver. */
i__1 = a_dim1 + 1;
anorm = (d__1 = A(1,1).r, abs(d__1)) + (d__2 = d_imag(&A(1,1)),
abs(d__2));
i__1 = b_dim1 + 1;
bnorm = (d__1 = B(1,1).r, abs(d__1)) + (d__2 = d_imag(&B(1,1)),
abs(d__2));
RWORK(1) = 0.;
RWORK(*n + 1) = 0.;
i__1 = *n;
for (j = 2; j <= *n; ++j) {
RWORK(j) = 0.;
RWORK(*n + j) = 0.;
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__3 = i + j * a_dim1;
RWORK(j) += (d__1 = A(i,j).r, abs(d__1)) + (d__2 = d_imag(&A(i,j)), abs(d__2));
i__3 = i + j * b_dim1;
RWORK(*n + j) += (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&
B(i,j)), abs(d__2));
/* L30: */
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = anorm, d__4 = RWORK(j) + ((d__1 = A(j,j).r, abs(d__1)) + (
d__2 = d_imag(&A(j,j)), abs(d__2)));
anorm = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * b_dim1;
d__3 = bnorm, d__4 = RWORK(*n + j) + ((d__1 = B(j,j).r, abs(d__1)) +
(d__2 = d_imag(&B(j,j)), abs(d__2)));
bnorm = max(d__3,d__4);
/* L40: */
}
ascale = 1. / max(anorm,safmin);
bscale = 1. / max(bnorm,safmin);
/* Left eigenvectors */
if (compl) {
ieig = 0;
/* Main loop over eigenvalues */
i__1 = *n;
for (je = 1; je <= *n; ++je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = SELECT(je);
}
if (ilcomp) {
++ieig;
i__2 = je + je * a_dim1;
i__3 = je + je * b_dim1;
if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
abs(d__3)) <= safmin) {
/* Singular matrix pencil -- return unit e
igenvector */
i__2 = *n;
for (jr = 1; jr <= *n; ++jr) {
i__3 = jr + ieig * vl_dim1;
VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L50: */
}
i__2 = ieig + ieig * vl_dim1;
VL(ieig,ieig).r = 1., VL(ieig,ieig).i = 0.;
goto L140;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
H
y ( a A - b B ) = 0
Computing MAX */
i__2 = je + je * a_dim1;
i__3 = je + je * b_dim1;
d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 =
B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__2 = je + je * a_dim1;
z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__2 = je + je * b_dim1;
sbeta = temp * B(je,je).r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__2 = *n;
for (jr = 1; jr <= *n; ++jr) {
i__3 = jr;
WORK(jr).r = 0., WORK(jr).i = 0.;
/* L60: */
}
i__2 = je;
WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__1,safmin);
/* H
Triangular solve of (a A - b B) y = 0
H
(rowwise in (a A - b B) , or columnwise in a
A - b B) */
i__2 = *n;
for (j = je + 1; j <= *n; ++j) {
/* Compute
j-1
SUM = sum conjg( a*A(k,j) - b*B(k,j) )
*x(k)
k=je
(Scale if necessary) */
temp = 1. / xmax;
if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) > bignum *
temp) {
i__3 = j - 1;
for (jr = je; jr <= j-1; ++jr) {
i__4 = jr;
i__5 = jr;
z__1.r = temp * WORK(jr).r, z__1.i = temp *
WORK(jr).i;
WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L70: */
}
xmax = 1.;
}
suma.r = 0., suma.i = 0.;
sumb.r = 0., sumb.i = 0.;
i__3 = j - 1;
for (jr = je; jr <= j-1; ++jr) {
d_cnjg(&z__3, &A(jr,j));
i__4 = jr;
z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
.i, z__2.i = z__3.r * WORK(jr).i + z__3.i *
WORK(jr).r;
z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
suma.r = z__1.r, suma.i = z__1.i;
d_cnjg(&z__3, &B(jr,j));
i__4 = jr;
z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
.i, z__2.i = z__3.r * WORK(jr).i + z__3.i *
WORK(jr).r;
z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
sumb.r = z__1.r, sumb.i = z__1.i;
/* L80: */
}
z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
d_cnjg(&z__4, &bcoeff);
z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i =
z__4.r * sumb.i + z__4.i * sumb.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
/* Form x(j) = - SUM / conjg( a*A(j,j) - b
*B(j,j) )
with scaling and perturbation of the de
nominator */
i__3 = j + j * a_dim1;
z__3.r = acoeff * A(j,j).r, z__3.i = acoeff * A(j,j).i;
i__4 = j + j * b_dim1;
z__4.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i,
z__4.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
d_cnjg(&z__1, &z__2);
d.r = z__1.r, d.i = z__1.i;
if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d.r = z__1.r, d.i = z__1.i;
}
if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
d__2)) < 1.) {
if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum),
abs(d__2)) >= bignum * ((d__3 = d.r, abs(d__3)
) + (d__4 = d_imag(&d), abs(d__4)))) {
temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 =
d_imag(&sum), abs(d__2)));
i__3 = j - 1;
for (jr = je; jr <= j-1; ++jr) {
i__4 = jr;
i__5 = jr;
z__1.r = temp * WORK(jr).r, z__1.i = temp *
WORK(jr).i;
WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L90: */
}
xmax = temp * xmax;
z__1.r = temp * sum.r, z__1.i = temp * sum.i;
sum.r = z__1.r, sum.i = z__1.i;
}
}
i__3 = j;
z__2.r = -sum.r, z__2.i = -sum.i;
z_div(&z__1, &z__2, &d);
WORK(j).r = z__1.r, WORK(j).i = z__1.i;
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = WORK(j).r, abs(d__1)) + (
d__2 = d_imag(&WORK(j)), abs(d__2));
xmax = max(d__3,d__4);
/* L100: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
i__2 = *n + 1 - je;
zgemv_("N", n, &i__2, &c_b2, &VL(1,je), ldvl,
&WORK(je), &c__1, &c_b1, &WORK(*n + 1), &c__1)
;
isrc = 2;
ibeg = 1;
} else {
isrc = 1;
ibeg = je;
}
/* Copy and scale eigenvector into column of VL
*/
xmax = 0.;
i__2 = *n;
for (jr = ibeg; jr <= *n; ++jr) {
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
d__2));
xmax = max(d__3,d__4);
/* L110: */
}
if (xmax > safmin) {
temp = 1. / xmax;
i__2 = *n;
for (jr = ibeg; jr <= *n; ++jr) {
i__3 = jr + ieig * vl_dim1;
i__4 = (isrc - 1) * *n + jr;
z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
(isrc-1)**n+jr).i;
VL(jr,ieig).r = z__1.r, VL(jr,ieig).i = z__1.i;
/* L120: */
}
} else {
ibeg = *n + 1;
}
i__2 = ibeg - 1;
for (jr = 1; jr <= ibeg-1; ++jr) {
i__3 = jr + ieig * vl_dim1;
VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L130: */
}
}
L140:
;
}
}
/* Right eigenvectors */
if (compr) {
ieig = im + 1;
/* Main loop over eigenvalues */
for (je = *n; je >= 1; --je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = SELECT(je);
}
if (ilcomp) {
--ieig;
i__1 = je + je * a_dim1;
i__2 = je + je * b_dim1;
if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
abs(d__3)) <= safmin) {
/* Singular matrix pencil -- return unit e
igenvector */
i__1 = *n;
for (jr = 1; jr <= *n; ++jr) {
i__2 = jr + ieig * vr_dim1;
VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L150: */
}
i__1 = ieig + ieig * vr_dim1;
VR(ieig,ieig).r = 1., VR(ieig,ieig).i = 0.;
goto L250;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
( a A - b B ) x = 0
Computing MAX */
i__1 = je + je * a_dim1;
i__2 = je + je * b_dim1;
d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 =
B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__1 = je + je * a_dim1;
z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__1 = je + je * b_dim1;
sbeta = temp * B(je,je).r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__1 = *n;
for (jr = 1; jr <= *n; ++jr) {
i__2 = jr;
WORK(jr).r = 0., WORK(jr).i = 0.;
/* L160: */
}
i__1 = je;
WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__1,safmin);
/* Triangular solve of (a A - b B) x = 0 (colum
nwise)
WORK(1:j-1) contains sums w,
WORK(j+1:JE) contains x */
i__1 = je - 1;
for (jr = 1; jr <= je-1; ++jr) {
i__2 = jr;
i__3 = jr + je * a_dim1;
z__2.r = acoeff * A(jr,je).r, z__2.i = acoeff * A(jr,je).i;
i__4 = jr + je * b_dim1;
z__3.r = bcoeff.r * B(jr,je).r - bcoeff.i * B(jr,je).i,
z__3.i = bcoeff.r * B(jr,je).i + bcoeff.i * B(jr,je)
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L170: */
}
i__1 = je;
WORK(je).r = 1., WORK(je).i = 0.;
for (j = je - 1; j >= 1; --j) {
/* Form x(j) := - w(j) / d
with scaling and perturbation of the de
nominator */
i__1 = j + j * a_dim1;
z__2.r = acoeff * A(j,j).r, z__2.i = acoeff * A(j,j).i;
i__2 = j + j * b_dim1;
z__3.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i,
z__3.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
d.r = z__1.r, d.i = z__1.i;
if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d.r = z__1.r, d.i = z__1.i;
}
if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
d__2)) < 1.) {
i__1 = j;
if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
&WORK(j)), abs(d__2)) >= bignum * ((d__3 =
d.r, abs(d__3)) + (d__4 = d_imag(&d), abs(
d__4)))) {
i__1 = j;
temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
d__2 = d_imag(&WORK(j)), abs(d__2)));
i__1 = je;
for (jr = 1; jr <= je; ++jr) {
i__2 = jr;
i__3 = jr;
z__1.r = temp * WORK(jr).r, z__1.i = temp *
WORK(jr).i;
WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
z__2.r = -WORK(j).r, z__2.i = -WORK(j).i;
z_div(&z__1, &z__2, &d);
WORK(j).r = z__1.r, WORK(j).i = z__1.i;
if (j > 1) {
/* w = w + x(j)*(a A(*,j) - b B(*,j
) ) with scaling */
i__1 = j;
if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
&WORK(j)), abs(d__2)) > 1.) {
i__1 = j;
temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
d__2 = d_imag(&WORK(j)), abs(d__2)));
if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) >=
bignum * temp) {
i__1 = je;
for (jr = 1; jr <= je; ++jr) {
i__2 = jr;
i__3 = jr;
z__1.r = temp * WORK(jr).r, z__1.i =
temp * WORK(jr).i;
WORK(jr).r = z__1.r, WORK(jr).i =
z__1.i;
/* L190: */
}
}
}
i__1 = j;
z__1.r = acoeff * WORK(j).r, z__1.i = acoeff *
WORK(j).i;
ca.r = z__1.r, ca.i = z__1.i;
i__1 = j;
z__1.r = bcoeff.r * WORK(j).r - bcoeff.i * WORK(
j).i, z__1.i = bcoeff.r * WORK(j).i +
bcoeff.i * WORK(j).r;
cb.r = z__1.r, cb.i = z__1.i;
i__1 = j - 1;
for (jr = 1; jr <= j-1; ++jr) {
i__2 = jr;
i__3 = jr;
i__4 = jr + j * a_dim1;
z__3.r = ca.r * A(jr,j).r - ca.i * A(jr,j).i,
z__3.i = ca.r * A(jr,j).i + ca.i * A(jr,j)
.r;
z__2.r = WORK(jr).r + z__3.r, z__2.i = WORK(
jr).i + z__3.i;
i__5 = jr + j * b_dim1;
z__4.r = cb.r * B(jr,j).r - cb.i * B(jr,j).i,
z__4.i = cb.r * B(jr,j).i + cb.i * B(jr,j)
.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L200: */
}
}
/* L210: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
zgemv_("N", n, &je, &c_b2, &VR(1,1), ldvr, &WORK(1),
&c__1, &c_b1, &WORK(*n + 1), &c__1);
isrc = 2;
iend = *n;
} else {
isrc = 1;
iend = je;
}
/* Copy and scale eigenvector into column of VR
*/
xmax = 0.;
i__1 = iend;
for (jr = 1; jr <= iend; ++jr) {
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
d__2));
xmax = max(d__3,d__4);
/* L220: */
}
if (xmax > safmin) {
temp = 1. / xmax;
i__1 = iend;
for (jr = 1; jr <= iend; ++jr) {
i__2 = jr + ieig * vr_dim1;
i__3 = (isrc - 1) * *n + jr;
z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
(isrc-1)**n+jr).i;
VR(jr,ieig).r = z__1.r, VR(jr,ieig).i = z__1.i;
/* L230: */
}
} else {
iend = 0;
}
i__1 = *n;
for (jr = iend + 1; jr <= *n; ++jr) {
i__2 = jr + ieig * vr_dim1;
VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of ZTGEVC */
} /* ztgevc_ */
/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *
lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
be selected by specifying either a range of values or a range of
indices for the desired eigenvalues.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found.
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found.
= 'I': the IL-th through IU-th eigenvalues will be found.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, the lower triangle (if UPLO='L') or the upper
triangle (if UPLO='U') of A, including the diagonal, is
destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) DOUBLE PRECISION
The absolute error tolerance for the eigenvalues.
An approximate eigenvalue is accepted as converged
when it is determined to lie in an interval [a,b]
of width less than or equal to
ABSTOL + EPS * max( |a|,|b| ) ,
where EPS is the machine precision. If ABSTOL is less than
or equal to zero, then EPS*|T| will be used in its place,
where |T| is the 1-norm of the tridiagonal matrix obtained
by reducing A to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('S').
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) DOUBLE PRECISION array, dimension (N)
On normal exit, the first M elements contain the selected
eigenvalues in ascending order.
Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and the
index of the eigenvector is returned in IFAIL.
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for ZHETRD returned by ILAENV.
RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt, itmp1, i, j, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static logical lower, wantz;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indiwk, indisp, indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *),
zsteqr_(char *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *),
zungtr_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *),
zunmtr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *);
static doublereal eps, vll, vuu, tmp1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (valeig && *n > 0 && *vu <= *vl) {
*info = -8;
} else if (indeig && *il < 1) {
*info = -9;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -10;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2)) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
WORK(1).r = 1., WORK(1).i = 0.;
return 0;
}
if (*n == 1) {
WORK(1).r = 1., WORK(1).i = 0.;
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
} else if (valeig) {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < A(1,1).r && *vu >= A(1,1).r) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *n - j + 1;
zdscal_(&i__2, &sigma, &A(j,j), &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
zdscal_(&j, &sigma, &A(1,j), &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &A(1,1), lda, &RWORK(indd), &RWORK(inde), &WORK(
indtau), &WORK(indwrk), &llwork, &iinfo);
i__1 = indwrk;
z__1.r = *n + WORK(indwrk).r, z__1.i = WORK(indwrk).i;
lopt = (integer) z__1.r;
/* If all eigenvalues are desired and ABSTOL is less than or equal to
zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for
some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &RWORK(indd), &c__1, &W(1), &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
dsterf_(n, &W(1), &RWORK(indee), info);
} else {
zlacpy_("A", n, n, &A(1,1), lda, &Z(1,1), ldz);
zungtr_(uplo, n, &Z(1,1), ldz, &WORK(indtau), &WORK(indwrk),
&llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
zsteqr_(jobz, n, &W(1), &RWORK(indee), &Z(1,1), ldz, &RWORK(
indrwk), info);
if (*info == 0) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
IFAIL(i) = 0;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &RWORK(indd), &
RWORK(inde), m, &nsplit, &W(1), &IWORK(indibl), &IWORK(indisp), &
RWORK(indrwk), &IWORK(indiwk), info);
if (wantz) {
zstein_(n, &RWORK(indd), &RWORK(inde), m, &W(1), &IWORK(indibl), &
IWORK(indisp), &Z(1,1), ldz, &RWORK(indrwk), &IWORK(
indiwk), &IFAIL(1), info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &A(1,1), lda, &WORK(indtau), &Z(1,1), ldz, &WORK(indwrk), &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &W(1), &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= *m-1; ++j) {
i = 0;
tmp1 = W(j);
i__2 = *m;
for (jj = j + 1; jj <= *m; ++jj) {
if (W(jj) < tmp1) {
i = jj;
tmp1 = W(jj);
}
/* L50: */
}
if (i != 0) {
itmp1 = IWORK(indibl + i - 1);
W(i) = W(j);
IWORK(indibl + i - 1) = IWORK(indibl + j - 1);
W(j) = tmp1;
IWORK(indibl + j - 1) = itmp1;
zswap_(n, &Z(1,i), &c__1, &Z(1,j), &
c__1);
if (*info != 0) {
itmp1 = IFAIL(i);
IFAIL(i) = IFAIL(j);
IFAIL(j) = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size.
Computing MAX */
i__1 = (*n << 1) - 1;
d__1 = (doublereal) max(i__1,lopt);
WORK(1).r = d__1, WORK(1).i = 0.;
return 0;
/* End of ZHEEVX */
} /* zheevx_ */
/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a,
integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGECON estimates the reciprocal of the condition number of a general
complex matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by ZGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The factors L and U from the factorization A = P*L*U
as computed by ZGETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ANORM (input) DOUBLE PRECISION
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
extern doublereal dlamch_(char *);
static doublereal sl;
static integer ix;
static doublereal su;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
zlatrs_("Lower", "No transpose", "Unit", normin, n, &A(1,1),
lda, &WORK(1), &sl, &RWORK(1), info);
/* Multiply by inv(U). */
zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);
} else {
/* Multiply by inv(U'). */
zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);
/* Multiply by inv(L'). */
zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &A(1,1), lda, &WORK(1), &sl, &RWORK(1), info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*/
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of ZGECON */
} /* zgecon_ */
/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka,
integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
real *w, complex *z, integer *ldz, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHBGV computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite banded eigenproblem, of
the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
and banded, and B is also positive definite.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
KA (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KA >= 0.
KB (input) INTEGER
The number of superdiagonals of the matrix B if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KB >= 0.
AB (input/output) COMPLEX array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first ka+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
On exit, the contents of AB are destroyed.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KA+1.
BB (input/output) COMPLEX array, dimension (LDBB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix B, stored in the first kb+1 rows of the array. The
j-th column of B is stored in the j-th column of the array BB
as follows:
if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
On exit, the factor S from the split Cholesky factorization
B = S**H*S, as returned by CPBSTF.
LDBB (input) INTEGER
The leading dimension of the array BB. LDBB >= KB+1.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors, with the i-th column of Z holding the
eigenvector associated with W(i). The eigenvectors are
normalized so that Z**H*B*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= N.
WORK (workspace) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is:
<= N: the algorithm failed to converge:
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then CPBSTF
returned INFO = i: B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
static integer inde;
static char vect[1];
extern logical lsame_(char *, char *);
static integer iinfo;
static logical upper, wantz;
extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
complex *, integer *, real *, real *, complex *, integer *,
complex *, integer *), chbgst_(char *, char *,
integer *, integer *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), cpbstf_(char
*, integer *, integer *, complex *, integer *, integer *);
static integer indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define BB(I,J) bb[(I)-1 + ((J)-1)* ( *ldbb)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ka < 0) {
*info = -4;
} else if (*kb < 0 || *kb > *ka) {
*info = -5;
} else if (*ldab < *ka + 1) {
*info = -7;
} else if (*ldbb < *kb + 1) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &BB(1,1), ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
chbgst_(jobz, uplo, n, ka, kb, &AB(1,1), ldab, &BB(1,1), ldbb,
&Z(1,1), ldz, &WORK(1), &RWORK(indwrk), &iinfo);
/* Reduce to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
chbtrd_(vect, uplo, n, ka, &AB(1,1), ldab, &W(1), &RWORK(inde), &Z(1,1), ldz, &WORK(1), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR.
*/
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
indwrk), info);
}
return 0;
/* End of CHBGV */
} /* chbgv_ */
void DenseMatrix<T>::_svd_helper (char JOBU,
char JOBVT,
std::vector<Real> & sigma_val,
std::vector<Number> & U_val,
std::vector<Number> & VT_val)
{
// M (input) int *
// The number of rows of the matrix A. M >= 0.
// In C/C++, pass the number of *cols* of A
int M = this->n();
// N (input) int *
// The number of columns of the matrix A. N >= 0.
// In C/C++, pass the number of *rows* of A
int N = this->m();
int min_MN = (M < N) ? M : N;
int max_MN = (M > N) ? M : N;
// A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
// On entry, the M-by-N matrix A.
// On exit,
// if JOBU = 'O', A is overwritten with the first min(m,n)
// columns of U (the left singular vectors,
// stored columnwise);
// if JOBVT = 'O', A is overwritten with the first min(m,n)
// rows of V**T (the right singular vectors,
// stored rowwise);
// if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
// are destroyed.
// Here, we pass &(_val[0]).
// LDA (input) int *
// The leading dimension of the array A. LDA >= max(1,M).
int LDA = M;
// S (output) DOUBLE PRECISION array, dimension (min(M,N))
// The singular values of A, sorted so that S(i) >= S(i+1).
sigma_val.resize( min_MN );
// LDU (input) INTEGER
// The leading dimension of the array U. LDU >= 1; if
// JOBU = 'S' or 'A', LDU >= M.
int LDU = M;
// U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
// (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
// If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
// if JOBU = 'S', U contains the first min(m,n) columns of U
// (the left singular vectors, stored columnwise);
// if JOBU = 'N' or 'O', U is not referenced.
if (JOBU == 'S')
U_val.resize( LDU*min_MN );
else
U_val.resize( LDU*M );
// LDVT (input) INTEGER
// The leading dimension of the array VT. LDVT >= 1; if
// JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
int LDVT = N;
if (JOBVT == 'S')
LDVT = min_MN;
// VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
// If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
// V**T;
// if JOBVT = 'S', VT contains the first min(m,n) rows of
// V**T (the right singular vectors, stored rowwise);
// if JOBVT = 'N' or 'O', VT is not referenced.
VT_val.resize( LDVT*N );
// LWORK (input) INTEGER
// The dimension of the array WORK.
// LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
// For good performance, LWORK should generally be larger.
//
// If LWORK = -1, then a workspace query is assumed; the routine
// only calculates the optimal size of the WORK array, returns
// this value as the first entry of the WORK array, and no error
// message related to LWORK is issued by XERBLA.
int larger = (3*min_MN+max_MN > 5*min_MN) ? 3*min_MN+max_MN : 5*min_MN;
int LWORK = (larger > 1) ? larger : 1;
// WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
// On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
// if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
// superdiagonal elements of an upper bidiagonal matrix B
// whose diagonal is in S (not necessarily sorted). B
// satisfies A = U * B * VT, so it has the same singular values
// as A, and singular vectors related by U and VT.
std::vector<Number> WORK( LWORK );
// INFO (output) INTEGER
// = 0: successful exit.
// < 0: if INFO = -i, the i-th argument had an illegal value.
// > 0: if DBDSQR did not converge, INFO specifies how many
// superdiagonals of an intermediate bidiagonal form B
// did not converge to zero. See the description of WORK
// above for details.
int INFO = 0;
// Ready to call the actual factorization routine through PETSc's interface.
#ifdef LIBMESH_USE_REAL_NUMBERS
// Note that the call to LAPACKgesvd_ may modify _val
LAPACKgesvd_(&JOBU, &JOBVT, &M, &N, &(_val[0]), &LDA, &(sigma_val[0]), &(U_val[0]),
&LDU, &(VT_val[0]), &LDVT, &(WORK[0]), &LWORK, &INFO);
#else
// When we have LIBMESH_USE_COMPLEX_NUMBERS then we must pass an array of Complex
// numbers to LAPACKgesvd_, but _val may contain Reals so we copy to Number below to
// handle both the real-valued and complex-valued cases.
std::vector<Number> val_copy(_val.size());
for(unsigned int i=0; i<_val.size(); i++)
{
val_copy[i] = _val[i];
}
std::vector<Real> RWORK(5 * min_MN);
LAPACKgesvd_(&JOBU, &JOBVT, &M, &N, &(val_copy[0]), &LDA, &(sigma_val[0]), &(U_val[0]),
&LDU, &(VT_val[0]), &LDVT, &(WORK[0]), &LWORK, &(RWORK[0]), &INFO);
#endif
// Check return value for errors
if (INFO != 0)
libmesh_error_msg("INFO=" << INFO << ", Error during Lapack SVD calculation!");
}
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *
e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c,
integer *ldc, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGBBRD reduces a complex general m-by-n band matrix A to real upper
bidiagonal form B by a unitary transformation: Q' * A * P = B.
The routine computes B, and optionally forms Q or P', or computes
Q'*C for a given matrix C.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether or not the matrices Q and P' are to be
formed.
= 'N': do not form Q or P';
= 'Q': form Q only;
= 'P': form P' only;
= 'B': form both.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
KL (input) INTEGER
The number of subdiagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals of the matrix A. KU >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the m-by-n band matrix A, stored in rows 1 to
KL+KU+1. The j-th column of A is stored in the j-th column of
the array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
On exit, A is overwritten by values generated during the
reduction.
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KL+KU+1.
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B.
E (output) REAL array, dimension (min(M,N)-1)
The superdiagonal elements of the bidiagonal matrix B.
Q (output) COMPLEX array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
If VECT = 'N' or 'P', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
PT (output) COMPLEX array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
If VECT = 'N' or 'Q', the array PT is not referenced.
LDPT (input) INTEGER
The leading dimension of the array PT.
LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
C (input/output) COMPLEX array, dimension (LDC,NCC)
On entry, an m-by-ncc matrix C.
On exit, C is overwritten by Q'*C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
WORK (workspace) COMPLEX array, dimension (max(M,N))
RWORK (workspace) REAL array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
static integer inca;
static real abst;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer i, j, l;
static complex t;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static complex ra;
static real rc;
static integer kk;
static complex rb;
static integer ml, nr, mu;
static complex rs;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
static integer kb1, ml0;
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define PT(I,J) pt[(I)-1 + ((J)-1)* ( *ldpt)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &Q(1,1), ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &PT(1,1), ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
first to lower bidiagonal form and then transform to upper
bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied
in
vector operations of length NR over the index set J1:J2:KLU1
.
The complex sines of the plane rotations are stored in WORK,
and the real cosines in RWORK.
Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
/* Reduce i-th column and i-th row of matrix to bidiagon
al form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= kb; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero
elements
which have been created below the band */
if (nr > 0) {
clargv_(&nr, &AB(klu1,j1-klm-1), &inca,
&WORK(j1), &kb1, &RWORK(j1), &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(klu1-l,j1-klm+l-1), &inca, &AB(klu1-l+1,j1-klm+l-1), &inca, &RWORK(j1), &WORK(
j1), &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i + 1) {
/* generate plane rotation to annih
ilate a(i+ml-1,i)
within the band, and apply rotat
ion from the left */
clartg_(&AB(*ku+ml-1,i), &AB(*ku+ml,i), &RWORK(i + ml - 1), &WORK(i +
ml - 1), &ra);
i__3 = *ku + ml - 1 + i * ab_dim1;
AB(*ku+ml-1,i).r = ra.r, AB(*ku+ml-1,i).i = ra.i;
if (i < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &AB(*ku+ml-2,i+1)
, &i__6, &AB(*ku+ml-1,i+1), &i__7, &RWORK(i + ml - 1), &
WORK(i + ml - 1));
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations i
n Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j));
crot_(m, &Q(1,j-1), &c__1, &Q(1,j), &c__1, &RWORK(j), &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
crot_(ncc, &C(j-1,1), ldc, &C(j,1),
ldc, &RWORK(j), &WORK(j));
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j-1,j+ku) abov
e the band
and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = WORK(j).r * AB(1,j+kun).r - WORK(j).i * AB(1,j+kun).i, q__1.i = WORK(j).r * AB(1,j+kun).i +
WORK(j).i * AB(1,j+kun).r;
WORK(j+kun).r = q__1.r, WORK(j+kun).i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = RWORK(j) * AB(1,j+kun).r, q__1.i = RWORK(j) *
AB(1,j+kun).i;
AB(1,j+kun).r = q__1.r, AB(1,j+kun).i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero
elements
which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &AB(1,j1+kun-1), &inca, &
WORK(j1 + kun), &kb1, &RWORK(j1 + kun), &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(l+1,j1+kun-1), &
inca, &AB(l,j1+kun), &inca, &
RWORK(j1 + kun), &WORK(j1 + kun), &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i + 1) {
/* generate plane rotation to annih
ilate a(i,i+mu-1)
within the band, and apply rotat
ion from the right */
clartg_(&AB(*ku-mu+3,i+mu-2), &
AB(*ku-mu+2,i+mu-1), &
RWORK(i + mu - 1), &WORK(i + mu - 1), &ra);
i__4 = *ku - mu + 3 + (i + mu - 2) * ab_dim1;
AB(*ku-mu+3,i+mu-2).r = ra.r, AB(*ku-mu+3,i+mu-2).i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i;
i__4 = min(i__3,i__5);
crot_(&i__4, &AB(*ku-mu+4,i+mu-2), &c__1, &AB(*ku-mu+3,i+mu-1), &c__1, &RWORK(i + mu - 1), &
WORK(i + mu - 1));
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations i
n P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j + kun));
crot_(n, &PT(j+kun-1,1), ldpt, &PT(j+kun,1), ldpt, &RWORK(j + kun), &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j+kl+ku,j+ku-1
) below the
band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = WORK(j+kun).r * AB(klu1,j+kun).r - WORK(j+kun).i * AB(klu1,j+kun).i, q__1.i = WORK(j+kun).r * AB(klu1,j+kun).i +
WORK(j+kun).i * AB(klu1,j+kun).r;
WORK(j+kb).r = q__1.r, WORK(j+kb).i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = RWORK(j+kun) * AB(klu1,j+kun).r, q__1.i = RWORK(j+kun) *
AB(klu1,j+kun).i;
AB(klu1,j+kun).r = q__1.r, AB(klu1,j+kun).i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by apply
ing
plane rotations from the left, overwriting superdiagonal
elements on subdiagonal elements
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i = 1; i <= min(*m-1,*n); ++i) {
clartg_(&AB(1,i), &AB(2,i), &rc, &rs, &ra)
;
i__2 = i * ab_dim1 + 1;
AB(1,i).r = ra.r, AB(1,i).i = ra.i;
if (i < *n) {
i__2 = i * ab_dim1 + 2;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rs.r * AB(1,i+1).r - rs.i * AB(1,i+1).i, q__1.i = rs.r
* AB(1,i+1).i + rs.i * AB(1,i+1).r;
AB(2,i).r = q__1.r, AB(2,i).i = q__1.i;
i__2 = (i + 1) * ab_dim1 + 1;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rc * AB(1,i+1).r, q__1.i = rc * AB(1,i+1).i;
AB(1,i+1).r = q__1.r, AB(1,i+1).i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &Q(1,i), &c__1, &Q(1,i+1),
&c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &C(i,1), ldc, &C(i+1,1), ldc, &rc,
&rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is
diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from
the
right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = AB(*ku,*m+1).r, rb.i = AB(*ku,*m+1).i;
for (i = *m; i >= 1; --i) {
clartg_(&AB(*ku+1,i), &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i * ab_dim1;
AB(*ku+1,i).r = ra.r, AB(*ku+1,i).i = ra.i;
if (i > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)
q__3.i;
i__1 = *ku + i * ab_dim1;
q__1.r = q__2.r * AB(*ku,i).r - q__2.i * AB(*ku,i).i,
q__1.i = q__2.r * AB(*ku,i).i + q__2.i * AB(*ku,i)
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i * ab_dim1;
i__2 = *ku + i * ab_dim1;
q__1.r = rc * AB(*ku,i).r, q__1.i = rc * AB(*ku,i).i;
AB(*ku,i).r = q__1.r, AB(*ku,i).i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &PT(i,1), ldpt, &PT(*m+1,1),
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D
and E */
i__1 = *ku + 1 + ab_dim1;
t.r = AB(*ku+1,1).r, t.i = AB(*ku+1,1).i;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
abst = c_abs(&t);
D(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &Q(1,i), &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &C(i,1), ldc);
}
if (i < minmn) {
if (*ku == 0 && *kl == 0) {
E(i) = 0.f;
i__2 = (i + 1) * ab_dim1 + 1;
t.r = AB(1,i+1).r, t.i = AB(1,i+1).i;
} else {
if (*ku == 0) {
i__2 = i * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = AB(2,i).r * q__2.r - AB(2,i).i * q__2.i,
q__1.i = AB(2,i).r * q__2.i + AB(2,i).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku,i+1).r * q__2.r - AB(*ku,i+1).i * q__2.i,
q__1.i = AB(*ku,i+1).r * q__2.i + AB(*ku,i+1).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
E(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &PT(i+1,1), ldpt);
}
i__2 = *ku + 1 + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku+1,i+1).r * q__2.r - AB(*ku+1,i+1).i * q__2.i, q__1.i =
AB(*ku+1,i+1).r * q__2.i + AB(*ku+1,i+1).i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGEQPF computes a QR factorization with column pivoting of a
complex M-by-N matrix A: A*P = Q*R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the orthogonal matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) COMPLEX*16 array, dimension (N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal temp, temp2;
static integer i, j, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer ma, mn;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublecomplex aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (JPVT(i) != 0) {
if (i != itemp) {
zswap_(m, &A(1,i), &c__1, &A(1,itemp), &
c__1);
JPVT(i) = JPVT(itemp);
JPVT(itemp) = i;
} else {
JPVT(i) = i;
}
++itemp;
} else {
JPVT(i) = i;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &A(1,1)
, lda, &TAU(1), &A(1,ma+1), lda, &WORK(1),
info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i = itemp + 1; i <= *n; ++i) {
i__2 = *m - itemp;
RWORK(i) = dznrm2_(&i__2, &A(itemp+1,i), &c__1);
RWORK(*n + i) = RWORK(i);
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i = itemp + 1; i <= mn; ++i) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i + 1;
pvt = i - 1 + idamax_(&i__2, &RWORK(i), &c__1);
if (pvt != i) {
zswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
RWORK(pvt) = RWORK(i);
RWORK(*n + pvt) = RWORK(*n + i);
}
/* Generate elementary reflector H(i) */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = *m - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &aii, &A(min(i+1,*m),i), &c__1, &TAU(i)
);
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i + 1;
i__3 = *n - i;
d_cnjg(&z__1, &TAU(i));
zlarf_("Left", &i__2, &i__3, &A(i,i), &c__1, &z__1,
&A(i,i+1), lda, &WORK(1));
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (RWORK(j) != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&A(i,j)) / RWORK(j);
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = RWORK(j) / RWORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
RWORK(j) = dznrm2_(&i__3, &A(i+1,j),
&c__1);
RWORK(*n + j) = RWORK(j);
} else {
RWORK(j) = 0.;
RWORK(*n + j) = 0.;
}
} else {
RWORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,
integer *ldab, real *anorm, real *rcond, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CPBCON estimates the reciprocal of the condition number (in the
1-norm) of a complex Hermitian positive definite band matrix using
the Cholesky factorization A = U**H*U or A = L*L**H computed by
CPBTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular factor stored in AB;
= 'L': Lower triangular factor stored in AB.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A, stored in the
first KD+1 rows of the array. The j-th column of U or L is
stored in the j-th column of the array AB as follows:
if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
ANORM (input) REAL
The 1-norm (or infinity-norm) of the Hermitian band matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real scale;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
static real scalel;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
integer *, integer *, complex *, integer *, complex *, real *,
real *, integer *);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real ainvnm;
extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
*);
static char normin[1];
static real smlnum;
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
} else if (*anorm < 0.f) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
} else {
/* Multiply by inv(L). */
clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = icamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((r__1 = WORK(ix).r, dabs(r__1)) + (r__2 = r_imag(&
WORK(ix)), dabs(r__2))) * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPBCON */
} /* cpbcon_ */
/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGELSS computes the minimum norm solution to a complex linear
least squares problem:
Minimize 2-norm(| b - A*x |).
using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
X.
The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the first min(m,n) rows of A are overwritten with
its right singular vectors, stored rowwise.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, B is overwritten by the N-by-NRHS solution matrix X.
If m >= n and RANK = n, the residual sum-of-squares for
the solution in the i-th column is given by the sum of
squares of elements n+1:m in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M,N).
S (output) DOUBLE PRECISION array, dimension (min(M,N))
The singular values of A in decreasing order.
The condition number of A in the 2-norm = S(1)/S(min(m,n)).
RCOND (input) DOUBLE PRECISION
RCOND is used to determine the effective rank of A.
Singular values S(i) <= RCOND*S(1) are treated as zero.
If RCOND < 0, machine precision is used instead.
RANK (output) INTEGER
The effective rank of A, i.e., the number of singular values
which are greater than RCOND*S(1).
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 1, and also:
LWORK >= 2*min(M,N) + max(M,N,NRHS)
For good performance, LWORK should generally be larger.
RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: the algorithm for computing the SVD failed to converge;
if INFO = i, i off-diagonal elements of an intermediate
bidiagonal form did not converge to zero.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__6 = 6;
static integer c_n1 = -1;
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b78 = 0.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau;
static doublecomplex vdum[1];
static integer i, iascl, ibscl, chunk;
static doublereal sfmin;
static integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer maxmn, itaup, itauq, mnthr;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer iwork;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer bl, ie, il;
extern doublereal dlamch_(char *);
static integer mm;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), zgebrd_(integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal bignum;
extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlascl_(char *, integer *, integer *, doublereal *, doublereal
*, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), zdrscl_(
integer *, doublereal *, doublecomplex *, integer *);
static integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zbdsqr_(
char *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, integer *);
static integer minwrk, maxwrk;
extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal smlnum;
static integer irwork;
extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
), zunmlq_(char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
), zunmqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static doublereal eps, thr;
#define VDUM(I) vdum[(I)]
#define S(I) s[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* 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 refers
to real workspace. NB refers to the optimal block size for the
immediately following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns
Space needed for ZBDSQR is BDSPAC = 5*N-1 */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR", "LT",
m, nrhs, n, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined
Space needed for ZBDSQR is BDSPC = 7*N+12
Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
"ZGEBRD", " ", &mm, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, "ZUNMBR",
"QLC", &mm, nrhs, n, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUN"
"GBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
minwrk = (*n << 1) + max(*nrhs,*m);
}
if (*n > *m) {
minwrk = (*m << 1) + max(*nrhs,*n);
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more colu
mns
than rows
Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1,
&c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(&
c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) * ilaenv_(&
c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "ZUNMLQ",
"LT", n, nrhs, m, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - underdetermined
Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD",
" ", m, n, &c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
"ZUNMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR"
, "P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
}
}
minwrk = max(minwrk,1);
maxwrk = max(minwrk,maxwrk);
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
}
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELSS", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
eps = dlamch_("P");
sfmin = dlamch_("S");
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", m, n, &A(1,1), lda, &RWORK(1));
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &A(1,1), lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &A(1,1), lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* VISMatrix all zero. Return zero solution. */
i__1 = max(*m,*n);
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &B(1,1), ldb);
dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &S(1), &minmn);
*rank = 0;
goto L70;
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = zlange_("M", m, nrhs, &B(1,1), ldb, &RWORK(1));
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 2;
}
/* Overdetermined case */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R
(CWorkspace: need 2*N, prefer N+N*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zgeqrf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__1,
info);
/* Multiply B by transpose(Q)
(CWorkspace: need N+NRHS, prefer N+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmqr_("L", "C", m, nrhs, n, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Zero out below R */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &A(2,1), lda);
}
}
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A
(CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
(RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(&mm, n, &A(1,1), lda, &S(1), &RWORK(ie), &WORK(itauq), &
WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R
(CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", &mm, nrhs, n, &A(1,1), lda, &WORK(itauq),
&B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors of R in A
(CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &A(1,1), lda, &WORK(itaup), &WORK(iwork), &
i__1, info);
irwork = ie + *n;
/* Perform bidiagonal QR iteration
multiply B by transpose of left singular vectors
compute right singular vectors in A
(CWorkspace: none)
(RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, &c__0, nrhs, &S(1), &RWORK(ie), &A(1,1), lda,
vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1), ldb);
}
/* L10: */
}
/* Multiply B by right singular vectors
(CWorkspace: need N, prefer N*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, n, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, n, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), n);
zlacpy_("G", n, &bl, &WORK(1), n, &B(1,1), ldb);
/* L20: */
}
} else {
zgemv_("C", n, n, &c_b2, &A(1,1), lda, &B(1,1), &c__1, &
c_b1, &WORK(1), &c__1);
zcopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) {
/* Underdetermined case, M much less than N
Path 2a - underdetermined, with many more columns than r
ows
and sufficient workspace for an efficient algorithm */
ldwork = *m;
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) {
ldwork = *lda;
}
itau = 1;
iwork = *m + 1;
/* Compute A=L*Q
(CWorkspace: need 2*M, prefer M+M*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__2,
info);
il = iwork;
/* Copy L to WORK(IL), zeroing out above it */
zlacpy_("L", m, m, &A(1,1), lda, &WORK(il), &ldwork);
i__2 = *m - 1;
i__1 = *m - 1;
zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &WORK(il + ldwork), &
ldwork);
ie = 1;
itauq = il + ldwork * *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IL)
(CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
(RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &WORK(il), &ldwork, &S(1), &RWORK(ie), &WORK(itauq),
&WORK(itaup), &WORK(iwork), &i__2, info);
/* Multiply B by transpose of left bidiagonalizing vectors
of L
(CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, m, &WORK(il), &ldwork, &WORK(
itauq), &B(1,1), ldb, &WORK(iwork), &i__2, info);
/* Generate right bidiagonalizing vectors of R in WORK(IL)
(CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &WORK(il), &ldwork, &WORK(itaup), &WORK(
iwork), &i__2, info);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, computing right singula
r
vectors of L in WORK(IL) and multiplying B by transpose
of
left singular vectors
(CWorkspace: need M*M)
(RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, nrhs, &S(1), &RWORK(ie), &WORK(il), &
ldwork, &A(1,1), lda, &B(1,1), ldb, &RWORK(
irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1),
ldb);
}
/* L30: */
}
iwork = il + *m * ldwork;
/* Multiply B by right singular vectors of L in WORK(IL)
(CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
zgemm_("C", "N", m, nrhs, m, &c_b2, &WORK(il), &ldwork, &B(1,1), ldb, &c_b1, &WORK(iwork), ldb);
zlacpy_("G", m, nrhs, &WORK(iwork), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = (*lwork - iwork + 1) / *m;
i__2 = *nrhs;
i__1 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", m, &bl, m, &c_b2, &WORK(il), &ldwork, &B(1,i), ldb, &c_b1, &WORK(iwork), n);
zlacpy_("G", m, &bl, &WORK(iwork), n, &B(1,1), ldb);
/* L40: */
}
} else {
zgemv_("C", m, m, &c_b2, &WORK(il), &ldwork, &B(1,1), &
c__1, &c_b1, &WORK(iwork), &c__1);
zcopy_(m, &WORK(iwork), &c__1, &B(1,1), &c__1);
}
/* Zero out below first M rows of B */
i__1 = *n - *m;
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &B(*m+1,1), ldb);
iwork = itau + *m;
/* Multiply transpose(Q) by B
(CWorkspace: need M+NRHS, prefer M+NHRS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmlq_("L", "C", n, nrhs, m, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases */
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A
(CWorkspace: need 3*M, prefer 2*M+(M+N)*NB)
(RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(m, n, &A(1,1), lda, &S(1), &RWORK(ie), &WORK(itauq),
&WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors
(CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, n, &A(1,1), lda, &WORK(itauq)
, &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors in A
(CWorkspace: need 3*M, prefer 2*M+M*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", m, n, m, &A(1,1), lda, &WORK(itaup), &WORK(
iwork), &i__1, info);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right singular vectors of A in A and
multiplying B by transpose of left singular vectors
(CWorkspace: none)
(RWorkspace: need BDSPAC) */
zbdsqr_("L", m, n, &c__0, nrhs, &S(1), &RWORK(ie), &A(1,1),
lda, vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1),
ldb);
}
/* L50: */
}
/* Multiply B by right singular vectors of A
(CWorkspace: need N, prefer N*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, m, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, m, &c_b2, &A(1,1), lda, &B(1,i), ldb, &c_b1, &WORK(1), n);
zlacpy_("F", n, &bl, &WORK(1), n, &B(1,i), ldb);
/* L60: */
}
} else {
zgemv_("C", m, n, &c_b2, &A(1,1), lda, &B(1,1), &
c__1, &c_b1, &WORK(1), &c__1);
zcopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
}
}
/* Undo scaling */
if (iascl == 1) {
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &B(1,1), ldb,
info);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
} else if (iascl == 2) {
zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &B(1,1), ldb,
info);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
}
if (ibscl == 1) {
zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
} else if (ibscl == 2) {
zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
}
L70:
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
return 0;
/* End of ZGELSS */
} /* zgelss_ */
/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du,
doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGTSVX uses the LU factorization to compute the solution to a complex
system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the LU decomposition is used to factor the matrix A
as A = L * U, where L is a product of permutation and unit lower
bidiagonal matrices and U is upper triangular with nonzeros in
only the main diagonal and first two superdiagonals.
2. The factored form of A is used to estimate the condition number
of the matrix A. If the reciprocal of the condition number is
less than machine precision, steps 3 and 4 are skipped.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form
of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
be modified.
= 'N': The matrix will be copied to DLF, DF, and DUF
and factored.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) COMPLEX*16 array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) COMPLEX*16 array, dimension (N)
The n diagonal elements of A.
DU (input) COMPLEX*16 array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input or output) COMPLEX*16 array, dimension (N-1)
If FACT = 'F', then DLF is an input argument and on entry
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A as computed by ZGTTRF.
If FACT = 'N', then DLF is an output argument and on exit
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A.
DF (input or output) COMPLEX*16 array, dimension (N)
If FACT = 'F', then DF is an input argument and on entry
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
If FACT = 'N', then DF is an output argument and on exit
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
DUF (input or output) COMPLEX*16 array, dimension (N-1)
If FACT = 'F', then DUF is an input argument and on entry
contains the (n-1) elements of the first superdiagonal of U.
If FACT = 'N', then DUF is an output argument and on exit
contains the (n-1) elements of the first superdiagonal of U.
DU2 (input or output) COMPLEX*16 array, dimension (N-2)
If FACT = 'F', then DU2 is an input argument and on entry
contains the (n-2) elements of the second superdiagonal of
U.
If FACT = 'N', then DU2 is an output argument and on exit
contains the (n-2) elements of the second superdiagonal of
U.
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains the pivot indices from the LU factorization of A as
computed by ZGTTRF.
If FACT = 'N', then IPIV is an output argument and on exit
contains the pivot indices from the LU factorization of A;
row i of the matrix was interchanged with row IPIV(i).
IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
a row interchange was not required.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) COMPLEX*16 array, dimension (LDX,NRHS)
If INFO = 0, the N-by-NRHS solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) DOUBLE PRECISION
The estimate of the reciprocal condition number of the matrix
A. If RCOND is less than the machine precision (in
particular, if RCOND = 0), the matrix is singular to working
precision. This condition is indicated by a return code of
INFO > 0, and the solution and error bounds are not computed.
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: U(i,i) is exactly zero. The factorization
has not been completed unless i = N, but the
factor U is exactly singular, so the solution
and error bounds could not be computed.
= N+1: RCOND is less than machine precision. The
factorization has been completed, but the
matrix is singular to working precision, and
the solution and error bounds have not been
computed.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
static char norm[1];
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlangt_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
static logical notran;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zgtcon_(char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *), zgtrfs_(char *,
integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *), zgttrf_(
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, integer *), zgttrs_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
nofact = lsame_(fact, "N");
notran = lsame_(trans, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
zcopy_(n, &D(1), &c__1, &DF(1), &c__1);
if (*n > 1) {
i__1 = *n - 1;
zcopy_(&i__1, &DL(1), &c__1, &DLF(1), &c__1);
i__1 = *n - 1;
zcopy_(&i__1, &DU(1), &c__1, &DUF(1), &c__1);
}
zgttrf_(n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = zlangt_(norm, n, &DL(1), &D(1), &DU(1));
/* Compute the reciprocal of the condition number of A. */
zgtcon_(norm, n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &anorm,
rcond, &WORK(1), info);
/* Return if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
return 0;
}
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
zgttrs_(trans, n, nrhs, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &X(1,1), ldx, info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
zgtrfs_(trans, n, nrhs, &DL(1), &D(1), &DU(1), &DLF(1), &DF(1), &DUF(1), &
DU2(1), &IPIV(1), &B(1,1), ldb, &X(1,1), ldx, &FERR(1),
&BERR(1), &WORK(1), &RWORK(1), info);
return 0;
/* End of ZGTSVX */
} /* zgtsvx_ */
/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, integer *n, complex *a, integer *lda, integer *sdim, complex *
w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *
work, integer *lwork, real *rwork, logical *bwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
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 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.
Arguments
=========
JOBVS (input) CHARACTER*1
= 'N': Schur vectors are not computed;
= 'V': Schur vectors are computed.
SORT (input) CHARACTER*1
Specifies whether or not to order the eigenvalues on the
diagonal of the Schur form.
= 'N': Eigenvalues are not ordered;
= 'S': Eigenvalues are ordered (see SELECT).
SELECT (input) LOGICAL FUNCTION of one COMPLEX argument
SELECT must be declared EXTERNAL in the calling subroutine.
If SORT = 'S', SELECT is used to select eigenvalues to order
to the top left of the Schur form.
If SORT = 'N', SELECT is not referenced.
An eigenvalue W(j) is selected if SELECT(W(j)) is true.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': None are computed;
= 'E': Computed for average of selected eigenvalues only;
= 'V': Computed for selected right invariant subspace only;
= 'B': Computed for both.
If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the N-by-N matrix A.
On exit, A is overwritten by its Schur form T.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
SDIM (output) INTEGER
If SORT = 'N', SDIM = 0.
If SORT = 'S', SDIM = number of eigenvalues for which
SELECT is true.
W (output) COMPLEX array, dimension (N)
W contains the computed eigenvalues, in the same order
that they appear on the diagonal of the output Schur form T.
VS (output) COMPLEX array, dimension (LDVS,N)
If JOBVS = 'V', VS contains the unitary matrix Z of Schur
vectors.
If JOBVS = 'N', VS is not referenced.
LDVS (input) INTEGER
The leading dimension of the array VS. LDVS >= 1, and if
JOBVS = 'V', LDVS >= N.
RCONDE (output) REAL
If SENSE = 'E' or 'B', RCONDE contains the reciprocal
condition number for the average of the selected eigenvalues.
Not referenced if SENSE = 'N' or 'V'.
RCONDV (output) REAL
If SENSE = 'V' or 'B', RCONDV contains the reciprocal
condition number for the selected right invariant subspace.
Not referenced if SENSE = 'N' or 'E'.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,2*N).
Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
where SDIM is the number of selected eigenvalues computed by
this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2.
For good performance, LWORK must generally be larger.
RWORK (workspace) REAL array, dimension (N)
BWORK (workspace) LOGICAL array, dimension (N)
Not referenced if SORT = 'N'.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, and i is
<= N: the QR algorithm failed to compute all the
eigenvalues; elements 1:ILO-1 and i+1:N of W
contain those eigenvalues which have converged; if
JOBVS = 'V', VS contains the transformation which
reduces A to its partially converged Schur form.
= N+1: the eigenvalues could not be reordered because some
eigenvalues were too close to separate (the problem
is very ill-conditioned);
= N+2: after reordering, roundoff changed values of some
complex eigenvalues so that leading eigenvalues in
the Schur form no longer satisfy SELECT=.TRUE. This
could also be caused by underflow due to scaling.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__4 = 4;
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ibal, maxb;
static real anrm;
static integer ierr, itau, iwrk, i, k, icond, ieval;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cgebak_(char *, char *, integer *, integer
*, integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
integer *, integer *, real *, integer *), slabad_(real *,
real *);
static logical scalea;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static real cscale;
extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), chseqr_(char *, char *, integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
integer *, integer *), cunghr_(integer *, integer
*, integer *, complex *, integer *, complex *, complex *, integer
*, integer *);
static logical wantsb;
extern /* Subroutine */ int ctrsen_(char *, char *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, complex *, integer *, integer *);
static logical wantse;
static integer minwrk, maxwrk;
static logical wantsn;
static real smlnum;
static integer hswork;
static logical wantst, wantsv, wantvs;
static integer ihi, ilo;
static real dum[1], eps;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define BWORK(I) bwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define VS(I,J) vs[(I)-1 + ((J)-1)* ( *ldvs)]
*info = 0;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -11;
}
/* 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 ILAENV.
HSWORK refers to the workspace preferred by 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 CTRSEN later
in the code.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &c__0,
6L, 1L);
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
if (! wantvs) {
/* Computing MAX */
i__1 = ilaenv_(&c__8, "CHSEQR", "SN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "CHSEQR", "SN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,hswork);
maxwrk = max(i__1,1);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "CHSEQR", "SV", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "CHSEQR", "SV", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,hswork);
maxwrk = max(i__1,1);
}
WORK(1).r = (real) maxwrk, WORK(1).i = 0.f;
}
if (*lwork < minwrk) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &A(1,1), lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &A(1,1), lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular
(CWorkspace: none)
(RWorkspace: need N) */
ibal = 1;
cgebal_("P", n, &A(1,1), lda, &ilo, &ihi, &RWORK(ibal), &ierr);
/* Reduce to upper Hessenberg form
(CWorkspace: need 2*N, prefer N+N*NB)
(RWorkspace: none) */
itau = 1;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, &ilo, &ihi, &A(1,1), lda, &WORK(itau), &WORK(iwrk), &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
clacpy_("L", n, n, &A(1,1), lda, &VS(1,1), ldvs);
/* Generate unitary matrix in VS
(CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
(RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &VS(1,1), ldvs, &WORK(itau), &WORK(iwrk),
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired
(CWorkspace: need 1, prefer HSWORK (see comments) )
(RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", jobvs, n, &ilo, &ihi, &A(1,1), lda, &W(1), &VS(1,1), ldvs, &WORK(iwrk), &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
clascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &W(1), n, &
ierr);
}
i__1 = *n;
for (i = 1; i <= *n; ++i) {
BWORK(i) = (*select)(&W(i));
/* L10: */
}
/* 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) */
i__1 = *lwork - iwrk + 1;
ctrsen_(sense, jobvs, &BWORK(1), n, &A(1,1), lda, &VS(1,1),
ldvs, &W(1), sdim, rconde, rcondv, &WORK(iwrk), &i__1, &
icond);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (icond == -14) {
/* Not enough complex workspace */
*info = -15;
}
}
if (wantvs) {
/* Undo balancing
(CWorkspace: none)
(RWorkspace: need N) */
cgebak_("P", "R", n, &ilo, &ihi, &RWORK(ibal), n, &VS(1,1),
ldvs, &ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
clascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &A(1,1), lda, &
ierr);
i__1 = *lda + 1;
ccopy_(n, &A(1,1), &i__1, &W(1), &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr);
*rcondv = dum[0];
}
}
WORK(1).r = (real) maxwrk, WORK(1).i = 0.f;
return 0;
/* End of CGEESX */
} /* cgeesx_ */
/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, complex *a, integer *lda, complex *b, integer
*ldb, real *tola, real *tolb, integer *k, integer *l, complex *u,
integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
integer *iwork, real *rwork, complex *tau, complex *work, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGGSVP computes unitary matrices U, V and Q such that
N-K-L K L
U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
L ( 0 0 A23 )
M-K-L ( 0 0 0 )
N-K-L K L
= K ( 0 A12 A13 ) if M-K-L < 0;
M-K ( 0 0 A23 )
N-K-L K L
V'*B*Q = L ( 0 0 B13 )
P-L ( 0 0 0 )
where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
conjugate transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
CGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Unitary matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Unitary matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Unitary matrix Q is computed;
= 'N': Q is not computed.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A contains the triangular (or trapezoidal) matrix
described in the Purpose section.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B contains the triangular matrix described in
the Purpose section.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TOLA (input) REAL
TOLB (input) REAL
TOLA and TOLB are the thresholds to determine the effective
numerical rank of matrix B and a subblock of A. Generally,
they are set to
TOLA = MAX(M,N)*norm(A)*MACHEPS,
TOLB = MAX(P,N)*norm(B)*MACHEPS.
The size of TOLA and TOLB may affect the size of backward
errors of the decomposition.
K (output) INTEGER
L (output) INTEGER
On exit, K and L specify the dimension of the subblocks
described in Purpose section.
K + L = effective numerical rank of (A',B')'.
U (output) COMPLEX array, dimension (LDU,M)
If JOBU = 'U', U contains the unitary matrix U.
If JOBU = 'N', U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M) if
JOBU = 'U'; LDU >= 1 otherwise.
V (output) COMPLEX array, dimension (LDV,M)
If JOBV = 'V', V contains the unitary matrix V.
If JOBV = 'N', V is not referenced.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P) if
JOBV = 'V'; LDV >= 1 otherwise.
Q (output) COMPLEX array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the unitary matrix Q.
If JOBQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N) if
JOBQ = 'Q'; LDQ >= 1 otherwise.
IWORK (workspace) INTEGER array, dimension (N)
RWORK (workspace) REAL array, dimension (2*N)
TAU (workspace) COMPLEX array, dimension (N)
WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The subroutine uses LAPACK subroutine CGEQPF for the QR factorization
with column pivoting to detect the effective numerical rank of the
a matrix. It may be replaced by a better rank determination strategy.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
static logical wantq, wantu, wantv;
extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *), cgerq2_(integer *,
integer *, complex *, integer *, complex *, complex *, integer *),
cung2r_(integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *), cunm2r_(char *, char *, integer
*, integer *, integer *, complex *, integer *, complex *, complex
*, integer *, complex *, integer *), cunmr2_(char
*, char *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *,
integer *, complex *, complex *, real *, integer *), clacpy_(char
*, integer *, integer *, complex *, integer *, complex *, integer
*), claset_(char *, integer *, integer *, complex *,
complex *, complex *, integer *), xerbla_(char *, integer
*), clapmt_(logical *, integer *, integer *, complex *,
integer *, integer *);
static logical forwrd;
#define IWORK(I) iwork[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define U(I,J) u[(I)-1 + ((J)-1)* ( *ldu)]
#define V(I,J) v[(I)-1 + ((J)-1)* ( *ldv)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (wantv || lsame_(jobv, "N"))) {
*info = -2;
} else if (! (wantq || lsame_(jobq, "N"))) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -8;
} else if (*ldb < max(1,*p)) {
*info = -10;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -16;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -18;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 )
( 0 0 ) */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
IWORK(i) = 0;
/* L10: */
}
cgeqpf_(p, n, &B(1,1), ldb, &IWORK(1), &TAU(1), &WORK(1), &RWORK(1),
info);
/* Update A := A*P */
clapmt_(&forwrd, m, n, &A(1,1), lda, &IWORK(1));
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i = 1; i <= min(*p,*n); ++i) {
i__2 = i + i * b_dim1;
if ((r__1 = B(i,i).r, dabs(r__1)) + (r__2 = r_imag(&B(i,i)
), dabs(r__2)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
claset_("Full", p, p, &c_b1, &c_b1, &V(1,1), ldv);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &B(2,1), ldb, &V(2,1),
ldv);
}
i__1 = min(*p,*n);
cung2r_(p, p, &i__1, &V(1,1), ldv, &TAU(1), &WORK(1), info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1; j <= *l-1; ++j) {
i__2 = *l;
for (i = j + 1; i <= *l; ++i) {
i__3 = i + j * b_dim1;
B(i,j).r = 0.f, B(i,j).i = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
claset_("Full", &i__1, n, &c_b1, &c_b1, &B(*l+1,1), ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
claset_("Full", n, n, &c_b1, &c_b2, &Q(1,1), ldq);
clapmt_(&forwrd, n, n, &Q(1,1), ldq, &IWORK(1));
}
if (*p >= *l && *n != *l) {
/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
cgerq2_(l, n, &B(1,1), ldb, &TAU(1), &WORK(1), info);
/* Update A := A*Z' */
cunmr2_("Right", "Conjugate transpose", m, n, l, &B(1,1), ldb, &
TAU(1), &A(1,1), lda, &WORK(1), info);
if (wantq) {
/* Update Q := Q*Z' */
cunmr2_("Right", "Conjugate transpose", n, n, l, &B(1,1),
ldb, &TAU(1), &Q(1,1), ldq, &WORK(1), info);
}
/* Clean up B */
i__1 = *n - *l;
claset_("Full", l, &i__1, &c_b1, &c_b1, &B(1,1), ldb);
i__1 = *n;
for (j = *n - *l + 1; j <= *n; ++j) {
i__2 = *l;
for (i = j - *n + *l + 1; i <= *l; ++i) {
i__3 = i + j * b_dim1;
B(i,j).r = 0.f, B(i,j).i = 0.f;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L
A = ( A11 A12 ) M,
then the following does the complete QR decomposition of A11:
A11 = U*( 0 T12 )*P1'
( 0 0 ) */
i__1 = *n - *l;
for (i = 1; i <= *n-*l; ++i) {
IWORK(i) = 0;
/* L70: */
}
i__1 = *n - *l;
cgeqpf_(m, &i__1, &A(1,1), lda, &IWORK(1), &TAU(1), &WORK(1), &RWORK(
1), info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
for (i = 1; i <= min(*m,*n-*l); ++i) {
i__2 = i + i * a_dim1;
if ((r__1 = A(i,i).r, dabs(r__1)) + (r__2 = r_imag(&A(i,i)
), dabs(r__2)) > *tola) {
++(*k);
}
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &A(1,1), lda, &
TAU(1), &A(1,*n-*l+1), lda, &WORK(1), info);
if (wantu) {
/* Copy the details of U, and form U */
claset_("Full", m, m, &c_b1, &c_b1, &U(1,1), ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
clacpy_("Lower", &i__1, &i__2, &A(2,1), lda, &U(2,1)
, ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
cung2r_(m, m, &i__1, &U(1,1), ldu, &TAU(1), &WORK(1), info);
}
if (wantq) {
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
clapmt_(&forwrd, n, &i__1, &Q(1,1), ldq, &IWORK(1));
}
/* Clean up A: set the strictly lower triangular part of
A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1; j <= *k-1; ++j) {
i__2 = *k;
for (i = j + 1; i <= *k; ++i) {
i__3 = i + j * a_dim1;
A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &A(*k+1,1), lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
cgerq2_(k, &i__1, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (wantq) {
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
i__1 = *n - *l;
cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &A(1,1),
lda, &TAU(1), &Q(1,1), ldq, &WORK(1), info)
;
}
/* Clean up A */
i__1 = *n - *l - *k;
claset_("Full", k, &i__1, &c_b1, &c_b1, &A(1,1), lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1; j <= *n-*l; ++j) {
i__2 = *k;
for (i = j - *n + *l + *k + 1; i <= *k; ++i) {
i__3 = i + j * a_dim1;
A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
cgeqr2_(&i__1, l, &A(*k+1,*n-*l+1), lda, &TAU(1), &
WORK(1), info);
if (wantu) {
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
cunm2r_("Right", "No transpose", m, &i__1, &i__2, &A(*k+1,*n-*l+1), lda, &TAU(1), &U(1,*k+1), ldu, &WORK(1), info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1; j <= *n; ++j) {
i__2 = *m;
for (i = j - *n + *k + *l + 1; i <= *m; ++i) {
i__3 = i + j * a_dim1;
A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of CGGSVP */
} /* cggsvp_ */
/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix A. If eigenvectors are desired, it uses a
divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
orthonormal eigenvectors of the matrix A.
If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
or the upper triangle (if UPLO='U') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if LWORK > 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK.
If N <= 1, LWORK must be at least 1.
If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
RWORK (workspace/output) DOUBLE PRECISION array,
dimension (LRWORK)
On exit, if LRWORK > 0, RWORK(1) returns the optimal LRWORK.
LRWORK (input) INTEGER
The dimension of the array RWORK.
If N <= 1, LRWORK must be at least 1.
If JOBZ = 'N' and N > 1, LRWORK must be at least N.
If JOBZ = 'V' and N > 1, LRWORK must be at least
1 + 4*N + 2*N*lg N + 3*N**2 ,
where lg( N ) = smallest integer k such
that 2**k >= N .
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If N <= 1, LIWORK must be at least 1.
If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
If JOBZ = 'V' and N > 1, LIWORK must be at least 2 + 5*N.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__0 = 0;
static doublereal c_b16 = 1.;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo, lwmin, liopt;
static logical lower;
static integer llrwk, lropt;
static logical wantz;
static integer indwk2, llwrk2;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), zlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
integer *), zstedc_(char *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *, integer
*);
static integer indrwk, indwrk, liwmin;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer lrwmin, llwork;
static doublereal smlnum;
extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lgn;
static doublereal eps;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (*n <= 1) {
lgn = 0;
lwmin = 1;
lrwmin = 1;
liwmin = 1;
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
} else {
lgn = (integer) (log((doublereal) (*n)) / log(2.));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (wantz) {
lwmin = (*n << 1) + *n * *n;
/* Computing 2nd power */
i__1 = *n;
lrwmin = (*n << 2) + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 5 + 2;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*lwork < lwmin) {
*info = -8;
} else if (*lrwork < lrwmin) {
*info = -10;
} else if (*liwork < liwmin) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVD ", &i__1);
goto L10;
}
/* Quick return if possible */
if (*n == 0) {
goto L10;
}
if (*n == 1) {
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
if (wantz) {
i__1 = a_dim1 + 1;
A(1,1).r = 1., A(1,1).i = 0.;
}
goto L10;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
zlascl_(uplo, &c__0, &c__0, &c_b16, &sigma, n, n, &A(1,1), lda,
info);
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
indrwk = inde + *n;
indwk2 = indwrk + *n * *n;
llwork = *lwork - indwrk + 1;
llwrk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indrwk + 1;
zhetrd_(uplo, n, &A(1,1), lda, &W(1), &RWORK(inde), &WORK(indtau), &
WORK(indwrk), &llwork, &iinfo);
/* Computing MAX */
i__1 = indwrk;
d__1 = (doublereal) lopt, d__2 = (doublereal) (*n) + WORK(indwrk).r;
lopt = (integer) max(d__1,d__2);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
tridiagonal matrix, then call ZUNMTR to multiply it to the
Householder transformations represented as Householder vectors in
A. */
if (! wantz) {
dsterf_(n, &W(1), &RWORK(inde), info);
} else {
zstedc_("I", n, &W(1), &RWORK(inde), &WORK(indwrk), n, &WORK(indwk2),
&llwrk2, &RWORK(indrwk), &llrwk, &IWORK(1), liwork, info);
zunmtr_("L", uplo, "N", n, n, &A(1,1), lda, &WORK(indtau), &WORK(
indwrk), n, &WORK(indwk2), &llwrk2, &iinfo);
zlacpy_("A", n, n, &WORK(indwrk), n, &A(1,1), lda);
/* Computing MAX
Computing 2nd power */
i__3 = *n;
i__4 = indwk2;
i__1 = lopt, i__2 = *n + i__3 * i__3 + (integer) WORK(indwk2).r;
lopt = max(i__1,i__2);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &W(1), &c__1);
}
L10:
if (*lwork > 0) {
WORK(1).r = (doublereal) lopt, WORK(1).i = 0.;
}
if (*lrwork > 0) {
RWORK(1) = (doublereal) lropt;
}
if (*liwork > 0) {
IWORK(1) = liopt;
}
return 0;
/* End of ZHEEVD */
} /* zheevd_ */
